'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