'From Squeak3.9alpha of 4 July 2005 [latest update: #7054] on 7 September 2006 at 11:17:37 pm'!
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 algorithm 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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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."

	| bitCount |
	frameSizeMask = 0 ifTrue: [^ bitsPerSample].
	"Following assumes mono:"
	bitCount := 16 + 6 + ((self samplesPerFrame - 1) * bitsPerSample).
	^ (bitCount + 7) // 8
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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 12/14/2001 11:21'!
reset

	self resetForMono.
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'stephaneducasse 2/4/2006 20:40'!
resetForMono
	"Reset my encoding and decoding state for mono."

	predicted := 0.
	index := 0.
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'stephaneducasse 2/4/2006 20:40'!
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: 'private' 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: 'private' stamp: 'stephaneducasse 2/4/2006 20:40'!
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: 'private' stamp: 'stephaneducasse 2/4/2006 20:40'!
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: 'private' stamp: 'jm 3/28/1999 08:59'!
encode: aSoundBuffer bitsPerSample: bits

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

!ADPCMCodec methodsFor: 'private' 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: 'private' stamp: 'stephaneducasse 2/4/2006 20:40'!
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 roundUpTo: self bytesPerEncodedFrame).
	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: 'private' stamp: 'stephaneducasse 2/4/2006 20:40'!
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: 'private' stamp: 'stephaneducasse 2/4/2006 20:40'!
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 actually 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: 'private' stamp: 'stephaneducasse 2/4/2006 20:40'!
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: 'private' stamp: 'stephaneducasse 2/4/2006 20:40'!
privateDecodeMono: count

	| delta step predictedDelta bit |
	<primitive: 'primitiveDecodeMono' module: 'ADPCMCodecPlugin'>
	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: 'private' stamp: 'stephaneducasse 2/4/2006 20:40'!
privateDecodeStereo: count

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

	<primitive: 'primitiveDecodeStereo' module: 'ADPCMCodecPlugin'>
	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: 'private' stamp: 'stephaneducasse 2/4/2006 20:40'!
privateEncodeMono: count

	| step sign diff delta predictedDelta bit p |
	<primitive: 'primitiveEncodeMono' module: 'ADPCMCodecPlugin'>
	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: 'private' stamp: 'ar 4/23/2001 15:12'!
privateEncodeStereo: count

	<primitive: 'primitiveEncodeStereo' module: 'ADPCMCodecPlugin'>
	"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: 'instance creation' stamp: 'jm 11/15/2001 16:02'!
newBitsPerSample: bitsPerSample

	^ super new
		initializeForBitsPerSample: bitsPerSample
		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:))
! !
Object subclass: #AIFFFileReader
	instanceVariableNames: 'in fileType channelCount frameCount bitsPerSample samplingRate channelData channelDataOffset 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: '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 10/20/2001 15:07'!
channelDataOffset

	^ channelDataOffset
! !

!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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: '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' stamp: 'stephaneducasse 2/4/2006 20:40'!
readFromFile: fileName mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag
	"Read the AIFF file of the given name. See comment in readFromStream:mergeIfStereo:skipDataChunk:."
	"AIFFFileReader new readFromFile: 'test.aiff' mergeIfStereo: false skipDataChunk: true"

	| f |
	f := (FileStream readOnlyFileNamed: fileName) binary.
	self readFromStream: f mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag.
	f close.
! !

!AIFFFileReader methodsFor: 'reading' stamp: 'stephaneducasse 2/4/2006 20:40'!
readFromStream: aBinaryStream mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag
	"Read an AIFF file from the given binary stream. 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."

	mergeIfStereo := mergeFlag.
	skipDataChunk := skipDataFlag.
	isLooped := false.
	gain := 1.0.
	self readFrom: aBinaryStream.
! !


!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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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 |
	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'].

	channelDataOffset := in position.  "record stream position for start of data"
	skipDataChunk ifTrue: [in skip: (chunkSize - 8). ^ self].  "if skipDataChunk, skip sample data"

	(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: 'stephaneducasse 2/4/2006 20:40'!
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]].
! !
Exception subclass: #Abort
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!

!Abort methodsFor: 'as yet unclassified' stamp: 'ajh 3/24/2003 00:55'!
defaultAction
	"No one has handled this error, but now give them a chance to decide how to debug it.  If none handle this either then open debugger (see UnhandedError-defaultAction)"

	UnhandledError signalForException: self! !
Object subclass: #AbstractEvent
	instanceVariableNames: 'item itemKind environment'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!AbstractEvent methodsFor: 'accessing' stamp: 'rw 6/30/2003 08:22'!
item
	"Return the item that triggered the event (typically the name of a class, a category, a protocol, a method)."

	^item! !

!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:43'!
itemCategory

	^self environmentAt: self class categoryKind! !

!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:43'!
itemClass

	^self environmentAt: self class classKind! !

!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/14/2003 12:10'!
itemExpression

	^self environmentAt: self class expressionKind! !

!AbstractEvent methodsFor: 'accessing' stamp: 'rw 6/30/2003 08:22'!
itemKind
	"Return the kind of the item of the event (#category, #class, #protocol, #method, ...)"

	^itemKind! !

!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:44'!
itemMethod

	^self environmentAt: self class methodKind! !

!AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:44'!
itemProtocol

	^self environmentAt: self class protocolKind! !

!AbstractEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 10:38'!
itemRequestor

	^self environmentAt: #requestor! !

!AbstractEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 10:38'!
itemSelector

	^self environmentAt: #selector! !


!AbstractEvent methodsFor: 'printing' stamp: 'NS 1/19/2004 17:52'!
printOn: aStream

	self printEventKindOn: aStream.
	aStream
		nextPutAll: ' Event for item: ';
		print: self item;
		nextPutAll: ' of kind: ';
		print: self itemKind! !


!AbstractEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:34'!
isAdded

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 18:41'!
isCategoryKnown

	^self itemCategory notNil! !

!AbstractEvent methodsFor: 'testing' stamp: 'rw 7/10/2003 15:01'!
isCommented

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'rw 7/14/2003 10:15'!
isDoIt

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 15:09'!
isModified

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'NS 1/21/2004 09:40'!
isProtocolKnown

	^self itemCategory notNil! !

!AbstractEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 19:53'!
isRecategorized

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:34'!
isRemoved

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:35'!
isRenamed

	^false! !

!AbstractEvent methodsFor: 'testing' stamp: 'NS 1/27/2004 12:44'!
isReorganized
	^ false! !


!AbstractEvent methodsFor: 'triggering' stamp: 'rw 7/14/2003 17:06'!
trigger: anEventManager 
	"Trigger the event manager."

	anEventManager triggerEvent: self eventSelector with: self.! !


!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:10'!
changeKind

	^self class changeKind! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:43'!
environmentAt: anItemKind

	(self itemKind = anItemKind) ifTrue: [^self item].
	^environment at: anItemKind ifAbsent: [nil]! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:20'!
eventSelector

	^self class eventSelectorBlock value: itemKind value: self changeKind! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:36'!
item: anItem kind: anItemKind

	item := anItem.
	itemKind := anItemKind.
	environment := Dictionary new! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:37'!
itemCategory: aCategory

	environment at: self class categoryKind put: aCategory! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:36'!
itemClass: aClass

	environment at: self class classKind put: aClass! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/14/2003 12:11'!
itemExpression: anExpression

	environment at: self class expressionKind put: anExpression! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:38'!
itemMethod: aMethod

	environment at: self class methodKind put: aMethod! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:38'!
itemProtocol: aProtocol

	environment at: self class protocolKind put: aProtocol! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'NS 1/27/2004 10:38'!
itemRequestor: requestor

	environment at: #requestor put: requestor! !

!AbstractEvent methodsFor: 'private-accessing' stamp: 'NS 1/27/2004 10:39'!
itemSelector: aSymbol

	environment at: #selector put: aSymbol! !

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

AbstractEvent class
	instanceVariableNames: ''!

!AbstractEvent class methodsFor: 'accessing' stamp: 'NS 1/16/2004 14:08'!
allChangeKinds
	"AbstractEvent allChangeKinds"

	^AbstractEvent allSubclasses collect: [:cl | cl changeKind]! !

!AbstractEvent class methodsFor: 'accessing' stamp: 'bvs 7/20/2004 12:12'!
allItemKinds
	"self allItemKinds"

	^(AbstractEvent class organization listAtCategoryNamed: #'item kinds') 
		collect: [:sel | self perform: sel]! !

!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:08'!
changeKind
	"Return a symbol, with a : as last character, identifying the change kind."

	self subclassResponsibility! !

!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:18'!
eventSelectorBlock

	^[:itemKind :changeKind | itemKind, changeKind, 'Event:']! !

!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:19'!
itemChangeCombinations

	^self supportedKinds collect: [:itemKind | self eventSelectorBlock value: itemKind value: self changeKind]! !

!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:04'!
supportedKinds
	"All the kinds of items that this event can take. By default this is all the kinds in the system. But subclasses can override this to limit the choices. For example, the SuperChangedEvent only works with classes, and not with methods, instance variables, ..."

	^self allItemKinds! !

!AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 11:39'!
systemEvents
	"Return all the possible events in the system. Make a cross product of 
	the items and the change types."
	"self systemEvents"

	^self allSubclasses
		inject: OrderedCollection new
		into: [:allEvents :eventClass | allEvents addAll: eventClass itemChangeCombinations; yourself]! !


!AbstractEvent class methodsFor: 'instance creation' stamp: 'ab 2/10/2005 16:32'!
classCategory: aName
	^ self item: aName kind: AbstractEvent categoryKind.! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 18:42'!
class: aClass
	^ self item: aClass kind: AbstractEvent classKind.! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 18:42'!
class: aClass category: cat 
	| instance |
	instance := self class: aClass.
	instance itemCategory: cat.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'rw 7/9/2003 11:19'!
item: anItem kind: anItemKind

	^self basicNew item: anItem kind: anItemKind! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/16/2004 14:19'!
method: aMethod class: aClass

	| instance |
	instance := self item: aMethod kind: self methodKind.
	instance itemClass: aClass.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/16/2004 14:20'!
method: aMethod protocol: prot class: aClass

	| instance |
	instance := self method: aMethod class: aClass.
	instance itemProtocol: prot.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:48'!
method: aMethod selector: aSymbol class: aClass

	| instance |
	instance := self item: aMethod kind: self methodKind.
	instance itemSelector: aSymbol.
	instance itemClass: aClass.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:49'!
method: aMethod selector: aSymbol class: aClass requestor: requestor

	| instance |
	instance := self method: aMethod selector: aSymbol class: aClass.
	instance itemRequestor: requestor.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:49'!
method: aMethod selector: aSymbol protocol: prot class: aClass

	| instance |
	instance := self method: aMethod selector: aSymbol class: aClass.
	instance itemProtocol: prot.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:50'!
method: aMethod selector: aSymbol protocol: prot class: aClass requestor: requestor

	| instance |
	instance := self method: aMethod selector: aSymbol protocol: prot class: aClass.
	instance itemRequestor: requestor.
	^instance! !

!AbstractEvent class methodsFor: 'instance creation' stamp: 'rw 6/30/2003 09:20'!
new
	"Override new to trigger an error, since we want to use specialized methods to create basic and higher-level events."

	^self error: 'Instances can only be created using specialized instance creation methods.'! !


!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'!
categoryKind

	^#category! !

!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'!
classKind

	^#class! !

!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/14/2003 11:41'!
expressionKind

	^#expression! !

!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'!
methodKind

	^#method! !

!AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/10/2003 12:36'!
protocolKind

	^#protocol! !


!AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 10:23'!
comment1

"Smalltalk organization removeElement: #ClassForTestingSystemChanges3
Smalltalk garbageCollect 
Smalltalk organizati

classify:under:


SystemChangeNotifier uniqueInstance releaseAll
SystemChangeNotifier uniqueInstance noMoreNotificationsFor: aDependent.


aDependent := SystemChangeNotifierTest new.
SystemChangeNotifier uniqueInstance
	notifyOfAllSystemChanges: aDependent
	using: #event:

SystemChangeNotifier uniqueInstance classAdded: #Foo inCategory: #FooCat



| eventSource dependentObject |
eventSource := EventManager new.
dependentObject := Object new.

register - dependentObject becomes dependent:
eventSource
	when: #anEvent send: #error to: dependentObject.

unregister dependentObject:
eventSource removeDependent: dependentObject.

[eventSource triggerEvent: #anEvent]
	on: Error
	do: [:exc | self halt: 'Should not be!!']."! !

!AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 10:24'!
comment2

"HTTPSocket useProxyServerNamed: 'proxy.telenet.be' port: 8080
TestRunner open

--------------------
We propose two orthogonal groups to categorize each event:
(1) the 'change type':
	added, removed, modified, renamed
	+ the composite 'changed' (see below for an explanation)
(2) the 'item type':
	class, method, instance variable, pool variable, protocol, category
	+ the composite 'any' (see below for an explanation).
The list of supported events is the cross product of these two lists (see below for an explicit enumeration of the events).

Depending on the change type, certain information related to the change is always present (for adding, the new things that was added, for removals, what was removed, for renaming, the old and the new name, etc.).

Depending on the item type, information regarding the item is present (for a method, which class it belongs to). 

Certain events 'overlap', for example, a method rename triggers a class change. To capture this I impose a hierarchy on the 'item types' (just put some numbers to clearly show the idea. They don't need numbers, really. Items at a certain categories are included by items one category number higher):
level 1 category
level 2 class
level 3 instance variable, pool variable, protocol, method.

Changes propagate according to this tree: any 'added', 'removed' or 'renamed' change type in level X triggers a 'changed' change type in level X - 1. A 'modified' change type does not trigger anything special.
For example, a method additions triggers a class modification. This does not trigger a category modification.

Note that we added 'composite events': wildcards for the 'change type' ('any' - any system additions) and for the 'item type' ('Changed' - all changes related to classes), and one for 'any change systemwide' (systemChanged).

This result is this list of Events:

classAdded
classRemoved
classModified
classRenamed (?)
classChanged (composite)

methodAdded
methodRemoved
methodModified
methodRenamed (?)
methodChanged (composite)

instanceVariableAdded
instanceVariableRemoved
instanceVariableModified 
instanceVariableRenamed (?)
instanceVariableChanged (composite)

protocolAdded
protocolRemoved
protocolModified
protocolRenamed (?)
protocolChanged (composite)

poolVariableAdded
poolVariableRemoved
poolVariableModified
poolVariableRenamed (?)
poolChanged (composite)

categoryAdded
categoryRemoved
categoryModified
categeryRenamed (?)
categoryChanged (composite)

anyAdded (composite)
anyRemoved (composite)
anyModified (composite)
anyRenamed (composite)

anyChanged (composite)



To check: can we pass somehow the 'source' of the change (a browser, a file-in, something else) ? Maybe by checking the context, but should not be too expensive either... I found this useful in some of my tools, but it might be too advanced to have in general. Tools that need this can always write code to check it for them.  But is not always simple...


Utilities (for the recent methods) and ChangeSet are the two main clients at this moment.

Important: make it very explicit that the event is send synchronously (or asynchronously, would we take that route).


					category
						class
							comment
							protocol
								method
OR
				category
				Smalltalk
					class
						comment
						protocol
						method
??



						Smalltalk	category
								\	/
								class
							/	  |	\
						comment  |	protocol
								  |	/
								method

"! !

!AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 15:43'!
comment3

"Things to consider for trapping:
ClassOrganizer>>#changeFromCategorySpecs:
	Problem: I want to trap this to send the appropriate bunch of ReCategorization events, but ClassOrganizer instances do not know where they belong to (what class, or what system); it just uses symbols. So I cannot trigger the change, because not enough information is available. This is a conceptual problem: the organization is stand-alone implementation-wise, while conceptually it belongs to a class. The clean solution could be to reroute this message to a class, but this does not work for all of the senders (that would work from the browserm but not for the file-in).

Browser>>#categorizeAllUncategorizedMethods
	Problem: should be trapped to send a ReCategorization event. However, this is model code that should not be in the Browser. Clean solution is to move it out of there to the model, and then trap it there (or reroute it to one of the trapped places).

Note: Debugger>>#contents:notifying: recompiles methods when needed, so I trapped it to get updates. However, I need to find a way to write a unit test for this. Haven't gotten around yet for doing this though...
"! !

!AbstractEvent class methodsFor: 'temporary' stamp: 'ar 9/27/2005 20:05'!
saveChangeNotificationAsSARFileWithNumber: aNumber 
	"Use the SARBuilder package to output the SystemChangeNotification 
	stuff as a SAR file. Put this statement here so that I don't forget it 
	when moving between images :-)"
	"self saveChangeNotificationAsSARFileWithNumber: 6"

	| filename changesText readmeText dumper |
	filename := 'SystemchangeNotification'.
	dumper := self class environment at: #SARChangeSetDumper ifAbsent: [ ^self ].
	changesText := 
'
0.6 Version for Squeak 3.7 (no longer for 3.6!!!!) Changed one hook method to make this version work in Squeak3.7. Download version 5 from http://www.iam.unibe.ch/~wuyts/SystemchangeNotification5.sar if you are working with Squeak 3.6.

0.5 Updated the safeguard mechanism so that clients with halts and errors do not stop all notifications. Added and updated new tests for this. If this interests you have a look at the class WeakActionSequenceTrappingErrors.

0.4 Ported to Squeak 3.6.

0.3 Added the hooks for instance variables (addition, removal and renaming). Refactored the tests.

0.2 Added hooks and tests for method removal and method recategorization.

0.1 First release'.
	readmeText :=
'Implements (part of) the system change notification mechanism. Clients that want to receive notifications about system changes should look at the category #public of the class SystemChangeNotifier, and the unit tests.

VERY IMPORTANT: This version is for Squeak 3.7 only. It will not work in Squeak version 3.6. Download and install the last version that worked in Squeak 3.6 (version 5) from the following URL: http://www.iam.unibe.ch/~wuyts/SystemchangeNotification5.sar'.

	(dumper
		on: Project current changeSet
		including: (ChangeSet allChangeSetNames
				select: [:ea | 'SystemChangeHooks' match: ea])) changesText: changesText;
		 readmeText: readmeText;
		 fileOutAsZipNamed: filename , aNumber printString , '.sar'! !
Object subclass: #AbstractFont
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Fonts'!
!AbstractFont commentStamp: '<historical>' prior: 0!
AbstractFont defines the generic interface that all fonts need to implement.!


!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'!
ascent

	self subclassResponsibility.
! !

!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'!
ascentOf: aCharacter

	^ self ascent.
! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:06'!
baseKern
	^0! !

!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'!
basicAscentOf: aCharacter

	^ self ascent.
! !

!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'!
basicDescentOf: aCharacter

	^ self descent.
! !

!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: 'nk 3/15/2004 18:57'!
derivativeFonts
	^#()! !

!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'!
descent

	self subclassResponsibility.
! !

!AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'!
descentOf: aCharacter

	^ self descent.
! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:15'!
familyName
	"Answer the name to be used as a key in the TextConstants dictionary."
	^self subclassResponsibility! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'!
height
	"Answer the height of the receiver, total of maximum extents of 
	characters above and below the baseline."

	^self subclassResponsibility! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 5/26/2003 09:45'!
isRegular
	^false! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'!
lineGrid
	"Answer the relative space between lines"

	^self subclassResponsibility! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:33'!
pixelSize
	"Make sure that we don't return a Fraction"
	^ TextStyle pointsToPixels: self pointSize! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 4/1/2004 10:48'!
pointSize
	self subclassResponsibility.! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 7/11/2004 21:15'!
textStyle
	^ TextStyle actualTextStyles detect:
		[:aStyle | aStyle fontArray includes: self] ifNone: [ TextStyle fontArray: { self } ]! !

!AbstractFont methodsFor: 'accessing' stamp: 'nk 3/22/2004 15:15'!
textStyleName
	"Answer the name to be used as a key in the TextConstants dictionary."
	^self familyName! !

!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: 'caching' stamp: 'nk 3/15/2004 18:47'!
releaseCachedState
	! !


!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: 'yo 1/7/2005 11:36'!
displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY
	"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! !


!AbstractFont methodsFor: 'measuring' stamp: 'tak 1/11/2005 17:20'!
approxWidthOfText: aText
"Return the width of aText -- quickly, and a little bit dirty. Used by lists morphs containing Text objects to get a quick, fairly accurate measure of the width of a list item."

    | w |
    
    (aText isNil or: [aText size == 0 ])
        ifTrue:[^0].
       
    w _ self
        widthOfString: aText asString.

     "If the text has no emphasis, just return the string size.  If it is empasized, 
    just approximate the width by adding about 20% to the width"   
    (((aText runLengthFor: 1) == aText size)
        and: [(aText emphasisAt: 1) == 0 ])
            ifTrue:[^w]
            ifFalse:[ ^w * 6 // 5 ]. ! !

!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 12/31/2001 14:25'!
widthOfString: aString
	aString ifNil:[^0].
	^self widthOfString: aString from: 1 to: aString size.
"
	TextStyle default defaultFont widthOfString: 'zort' 21
"! !

!AbstractFont methodsFor: 'measuring' stamp: 'ar 12/31/2001 00:54'!
widthOfString: aString from: startIndex to: stopIndex
	"Measure the length of the given string between start and stop index"
	| character resultX |
	resultX _ 0.
	startIndex to: stopIndex do:[:i | 
		character _ aString at: i.
		resultX _ resultX + (self widthOf: character)].
	^resultX! !

!AbstractFont methodsFor: 'measuring' stamp: 'sps 3/23/2004 15:50'!
widthOfStringOrText: aStringOrText
    aStringOrText ifNil:[^0].
    ^aStringOrText isText
        ifTrue:[self approxWidthOfText: aStringOrText ]
        ifFalse:[self widthOfString: aStringOrText ] ! !


!AbstractFont methodsFor: 'notifications' stamp: 'nk 4/2/2004 11:25'!
pixelsPerInchChanged
	"The definition of TextStyle class>>pixelsPerInch has changed. Do whatever is necessary."! !


!AbstractFont methodsFor: 'testing' stamp: 'nk 6/25/2003 12:54'!
isTTCFont
	^false! !


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

AbstractFont class
	instanceVariableNames: ''!

!AbstractFont class methodsFor: 'as yet unclassified' stamp: 'nk 9/1/2004 11:41'!
emphasisStringFor: emphasisCode
	"Answer a translated string that represents the attributes given in emphasisCode."

	| emphases bit |
	emphasisCode = 0 ifTrue: [ ^'Normal' translated ].

	emphases := (IdentityDictionary new)
		at: 1 put: 'Bold' translated;
		at: 2 put: 'Italic' translated;
		at: 4 put: 'Underlined' translated;
		at: 8 put: 'Narrow' translated;
		at: 16 put: 'StruckOut' translated;
		yourself.

	bit := 1.
	^String streamContents: [ :s |
		[ bit < 32 ] whileTrue: [ | code |
			code := emphasisCode bitAnd: bit.
			code isZero ifFalse: [ s nextPutAll: (emphases at: code); space ].
			bit := bit bitShift: 1 ].
		s position isZero ifFalse: [ s skip: -1 ].
	]! !
Model subclass: #AbstractHierarchicalList
	instanceVariableNames: 'currentSelection myBrowser'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-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: #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: 'running' stamp: 'tk 10/24/2001 06:40'!
startUp
	"A backstop for subclasses.  Note that this is not a class message (most startUps are class messages)."

! !


!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: 'mdr 4/10/2001 10:50'!
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 class
	instanceVariableNames: ''!

!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'!
deactivate
	"Unregister this launcher with the auto start class"
	self autoStarter removeLauncher: self! !


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

!AbstractLauncher class methodsFor: 'private' stamp: 'sd 9/30/2003 13:55'!
extractParameters
	
	^ SmalltalkImage current extractParameters! !
RectangleMorph subclass: #AbstractMediaEventMorph
	instanceVariableNames: 'startTimeInScore endTimeInScore'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-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: 'initialization' stamp: 'dgd 2/14/2003 22:36'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!AbstractMediaEventMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color paleYellow! !

!AbstractMediaEventMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:38'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self layoutPolicy: TableLayout new;
	  listDirection: #leftToRight;
	  wrapCentering: #topLeft;
	  hResizing: #shrinkWrap;
	  vResizing: #shrinkWrap;
	  layoutInset: 2;
	  rubberBandCells: true! !


!AbstractMediaEventMorph methodsFor: '*sound-piano rolls' stamp: 'stephaneducasse 2/4/2006 20:40'!
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: #AbstractObjectsAsMethod
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-ObjectsAsMethods'!

!AbstractObjectsAsMethod methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 14:25'!
flushCache! !

!AbstractObjectsAsMethod methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 14:23'!
methodClass: aMethodClass! !

!AbstractObjectsAsMethod methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 14:23'!
selector: aSymbol! !
Morph subclass: #AbstractResizerMorph
	instanceVariableNames: 'dotColor handleColor lastMouse'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!AbstractResizerMorph commentStamp: 'jmv 1/29/2006 17:15' prior: 0!
I am the superclass of a hierarchy of morph specialized in allowing the user to resize or rearrange windows and panes.!


!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:36'!
dotColor

	^ dotColor ifNil: [self setDefaultColors. dotColor]! !

!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:35'!
handleColor

	^ handleColor ifNil: [self setDefaultColors. handleColor]! !

!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:37'!
handlesMouseDown: anEvent

	^ true! !

!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:37'!
handlesMouseOver: anEvent

	^ true
	! !

!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'md 2/24/2006 23:01'!
initialize

	super initialize.
	self color: Color transparent! !

!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:40'!
isCursorOverHandle

	^ true! !

!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:42'!
mouseDown: anEvent

	lastMouse _ anEvent cursorPoint! !

!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'md 2/24/2006 23:01'!
mouseEnter: anEvent

	self isCursorOverHandle ifTrue:
		[self setInverseColors.
		self changed.
		anEvent hand showTemporaryCursor: self resizeCursor]! !

!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:37'!
mouseLeave: anEvent

	anEvent hand showTemporaryCursor: nil.
	self setDefaultColors.
	self changed! !

!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/5/2005 21:37'!
resizeCursor

	self subclassResponsibility! !

!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/29/2005 13:25'!
setDefaultColors

	handleColor _ Color lightGray lighter lighter.
	dotColor _ Color gray lighter! !

!AbstractResizerMorph methodsFor: 'as yet unclassified' stamp: 'jrp 7/30/2005 21:30'!
setInverseColors

	handleColor _ Color lightGray.
	dotColor _ Color white! !
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'accessing' stamp: 'jm 12/16/2001 22:34'!
isStereo
	"Answer true if this sound has distinct left and right channels. (Every sound plays into a stereo sample buffer, but most sounds, which produce exactly the same samples on both channels, are not stereo.)"

	^ false
! !


!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: 'conversion' stamp: 'jm 12/16/2001 13:26'!
asSampledSound
	"Answer a SampledSound containing my samples. If the receiver is some kind of sampled sound, the resulting SampledSound will have the same original sampling rate as the receiver."

	^ SampledSound samples: self samples samplingRate: self originalSamplingRate
! !


!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: 'stephaneducasse 2/4/2006 20:40'!
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: 'envelopes' stamp: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
removeAllEnvelopes
	"Remove all envelopes from my envelopes list."

	envelopes := #().
! !

!AbstractSound methodsFor: 'envelopes' stamp: 'stephaneducasse 2/4/2006 20:40'!
removeEnvelope: anEnvelope
	"Remove the given envelope from my envelopes list."

	envelopes := envelopes copyWithout: anEnvelope.
! !


!AbstractSound methodsFor: 'file i/o' stamp: 'stephaneducasse 2/4/2006 20:40'!
storeAIFFOnFileNamed: fileName
	"Store this sound as a AIFF file of the given name."

	| f |
	f := (FileStream fileNamed: fileName) binary.
	self storeAIFFSamplesOn: f.
	f close.
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'stephaneducasse 2/4/2006 20:40'!
storeAIFFSamplesOn: aBinaryStream
	"Store this sound as a 16-bit AIFF file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound."

	| samplesToStore channelCount dataByteCount |
	samplesToStore := (self duration * self samplingRate) ceiling.
	channelCount := self isStereo ifTrue: [2] ifFalse: [1].
	dataByteCount := samplesToStore * channelCount * 2.

	"write AIFF file header:"
	aBinaryStream nextPutAll: 'FORM' asByteArray.
	aBinaryStream nextInt32Put: ((7 * 4) + 18) + dataByteCount.
	aBinaryStream nextPutAll: 'AIFF' asByteArray.
	aBinaryStream nextPutAll: 'COMM' asByteArray.
	aBinaryStream nextInt32Put: 18.
	aBinaryStream nextNumber: 2 put: channelCount.
	aBinaryStream nextInt32Put: samplesToStore.
	aBinaryStream nextNumber: 2 put: 16.  "bits/sample"
	self storeExtendedFloat: self samplingRate on: aBinaryStream.
	aBinaryStream nextPutAll: 'SSND' asByteArray.
	aBinaryStream nextInt32Put: dataByteCount + 8.
	aBinaryStream nextInt32Put: 0.
	aBinaryStream nextInt32Put: 0.

	"write data:"
	self storeSampleCount: samplesToStore bigEndian: true on: aBinaryStream.
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream
	"Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files). If self isStereo is true, both channels are stored, creating a stereo file. Otherwise, only the left channel is stored, creating a mono file."

	| bufSize stereoBuffer reverseBytes remaining out |
	self reset.
	bufSize := (2 * self samplingRate rounded) min: samplesToStore.  "two second buffer"
	stereoBuffer := SoundBuffer newStereoSampleCount: bufSize.
	reverseBytes := bigEndianFlag ~= (SmalltalkImage current isBigEndian).

	'Storing audio...' displayProgressAt: Sensor cursorPoint
		from: 0 to: samplesToStore during: [:bar |
			remaining := samplesToStore.
			[remaining > 0] whileTrue: [
				bar value: samplesToStore - remaining.
				stereoBuffer primFill: 0.  "clear the buffer"
				self playSampleCount: (bufSize min: remaining) into: stereoBuffer startingAt: 1.
				self isStereo
					ifTrue: [out := stereoBuffer]
					ifFalse: [out := stereoBuffer extractLeftChannel].
				reverseBytes ifTrue: [out reverseEndianness].
				(aBinaryStream isKindOf: StandardFileStream)
					ifTrue: [  "optimization for files: write sound buffer directly to file"
						aBinaryStream next: (out size // 2) putAll: out startingAt: 1]  "size in words"
					ifFalse: [  "for non-file streams:"
						1 to: out monoSampleCount do: [:i | aBinaryStream int16: (out at: i)]].
				remaining := remaining - bufSize]].
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'stephaneducasse 2/4/2006 20:40'!
storeSunAudioOnFileNamed: fileName
	"Store this sound as an uncompressed Sun audio file of the given name."

	| f |
	f := (FileStream fileNamed: fileName) binary.
	self storeSunAudioSamplesOn: f.
	f close.
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'stephaneducasse 2/4/2006 20:40'!
storeSunAudioSamplesOn: aBinaryStream
	"Store this sound as a 16-bit Sun audio file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound."


	| samplesToStore channelCount dataByteCount |
	samplesToStore := (self duration * self samplingRate) ceiling.
	channelCount := self isStereo ifTrue: [2] ifFalse: [1].
	dataByteCount := samplesToStore * channelCount * 2.

	"write Sun audio file header"
	channelCount := self isStereo ifTrue: [2] ifFalse: [1].
	aBinaryStream nextPutAll: '.snd' asByteArray.
	aBinaryStream uint32: 24.	"header size in bytes"
	aBinaryStream uint32: dataByteCount.
	aBinaryStream uint32: 3.	"format: 16-bit linear"
	aBinaryStream uint32: self samplingRate truncated.
	aBinaryStream uint32: channelCount.

	"write data:"
	self storeSampleCount: samplesToStore bigEndian: true on: aBinaryStream.
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'stephaneducasse 2/4/2006 20:40'!
storeWAVOnFileNamed: fileName
	"Store this sound as a 16-bit Windows WAV file of the given name."

	| f |
	f := (FileStream fileNamed: fileName) binary.
	self storeWAVSamplesOn: f.
	f close.
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'stephaneducasse 2/4/2006 20:40'!
storeWAVSamplesOn: aBinaryStream
	"Store this sound as a 16-bit Windows WAV file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound."

	| samplesToStore channelCount dataByteCount samplesPerSec bytesPerSec |
	samplesToStore := (self duration * self samplingRate) ceiling.
	channelCount := self isStereo ifTrue: [2] ifFalse: [1].
	dataByteCount := samplesToStore * channelCount * 2.
	samplesPerSec := self samplingRate rounded.
	bytesPerSec := samplesPerSec * channelCount * 2.

	"file header"
	aBinaryStream
		nextPutAll: 'RIFF' asByteArray;
		nextLittleEndianNumber: 4 put: dataByteCount + 36;	"total length of all chunks"
		nextPutAll: 'WAVE' asByteArray.

	"format chunk"
	aBinaryStream
		nextPutAll: 'fmt ' asByteArray;
		nextLittleEndianNumber: 4 put: 16;	"length of this chunk"
		nextLittleEndianNumber: 2 put: 1;	"format tag"
		nextLittleEndianNumber: 2 put: channelCount;
		nextLittleEndianNumber: 4 put: samplesPerSec;
		nextLittleEndianNumber: 4 put: bytesPerSec;
		nextLittleEndianNumber: 2 put: 4;	"alignment"
		nextLittleEndianNumber: 2 put: 16.	"bits per sample"

	"data chunk"
	aBinaryStream
		nextPutAll: 'data' asByteArray;
		nextLittleEndianNumber: 4 put: dataByteCount.  "length of this chunk"

	self storeSampleCount: samplesToStore bigEndian: false on: aBinaryStream.
! !


!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: 'stephaneducasse 2/4/2006 20:40'!
initialize

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

!AbstractSound methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'playing' stamp: 'stephaneducasse 2/4/2006 20:40'!
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' stamp: 'gk 2/24/2004 22:23'!
play
	"Play this sound to the sound output 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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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 12/16/2001 13:22'!
samples
	"Answer a monophonic sample buffer containing my samples. The left and write channels are merged."
	"Warning: This may require a lot of memory!!"

	^ (self computeSamplesForSeconds: self duration) mergeStereo
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 12/16/2001 13:24'!
viewSamples
	"Open a WaveEditor on my samples."

	WaveEditor openOn: self samples.
! !


!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/16/2001 13:14'!
originalSamplingRate
	"For sampled sounds, answer the sampling rate used to record the stored samples. For other sounds, this is the same as the playback sampling rate."

	^ SoundPlayer samplingRate
! !

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

	^ SoundPlayer samplingRate
! !


!AbstractSound methodsFor: 'sound generation' stamp: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'volume' stamp: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
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 class
	instanceVariableNames: ''!

!AbstractSound class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:41'!
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: 'examples' stamp: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
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: '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: 'stephaneducasse 2/4/2006 20:41'!
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: '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:)
	).
! !


!AbstractSound class methodsFor: 'sound library' stamp: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
fileInSoundLibrary
	"Prompt the user for a file name and the file in the sound library with that name."
	"AbstractSound fileInSoundLibrary"

	| fileName |
	fileName := UIManager default 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: 'stephaneducasse 2/4/2006 20:41'!
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: 'rbb 3/1/2005 10:21'!
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 := UIManager default 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: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
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: 'utilities' stamp: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
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' stamp: 'stephaneducasse 2/4/2006 20:41'!
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: 'stephaneducasse 2/4/2006 20:41'!
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
! !
Object subclass: #AbstractSoundSystem
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!AbstractSoundSystem commentStamp: 'gk 2/24/2004 08:34' prior: 0!
This is the abstract base class for a sound system. A sound system offers a small protocol for playing sounds and making beeps and works like a facade towards the rest of Squeak. A sound system is registered in the application registry SoundService and can be accessed by "SoundService default" like for example:

SoundService default playSoundNamed: 'croak'

The idea is that as much sound playing as possible should go through this facade. This way we decouple the sound system from the rest of Squeak and make it pluggable. It also is a perfect spot to check for the Preference class>>soundsEnabled.

Two basic subclasses exist at the time of this writing, the BaseSoundSystem which represents the standard Squeak sound system, and the DummySoundSystem which is a dummy implementation that can be used when there is no sound card available, or when the base sound system isn't in the image, or when you simply don't want to use the available sound card.!


!AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'!
randomBitsFromSoundInput: bitCount

	self subclassResponsibility! !

!AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'!
sampledSoundChoices

	self subclassResponsibility! !

!AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:53'!
shutDown
	"Default is to do nothing."! !

!AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:56'!
soundNamed: soundName

	self subclassResponsibility! !


!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/24/2004 23:27'!
beep
	"Make a primitive beep."

	self subclassResponsibility! !

!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:47'!
playSampledSound: samples rate: rate

	self subclassResponsibility! !

!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:50'!
playSoundNamed: soundName

	self subclassResponsibility! !

!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'!
playSoundNamed: soundName ifAbsentReadFrom: aifFileName

	self subclassResponsibility! !

!AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'!
playSoundNamedOrBeep: soundName

	self subclassResponsibility! !
PluggableTextMorph subclass: #AcceptableCleanTextMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Pluggable Widgets'!

!AcceptableCleanTextMorph methodsFor: 'menu commands' stamp: 'dgd 2/21/2003 22:50'!
accept
	"Overridden to allow accept of clean text"

	| textToAccept ok |
	textToAccept := textMorph asText.
	ok := setTextSelector isNil 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: 'LegalCharMap'
	poolDictionaries: ''
	category: 'Files-Directories'!

!AcornFileDirectory methodsFor: 'file name utilities' stamp: 'stephaneducasse 2/4/2006 20:31'!
checkName: aFileName fixErrors: fixing
	"Check if the file name contains any invalid characters"
	| fName hasBadChars correctedName newChar|
	fName := super checkName: aFileName fixErrors: fixing.
	correctedName := String streamContents:[:s|
								fName do:[:c|
									(newChar := LegalCharMap at: c asciiValue +1) ifNotNil:[s nextPut: newChar]]]. 
	hasBadChars := fName ~= correctedName.
	(hasBadChars and:[fixing not]) ifTrue:[^self error:'Invalid file name'].
	hasBadChars ifFalse:[^ fName].
	^ correctedName! !

!AcornFileDirectory methodsFor: 'file name utilities' stamp: 'tpr 11/5/2004 13:08'!
fullPathFor: path
	"if the arg is an empty string, just return my path name converted via the language stuff. 
If the arg seems to be a  rooted path, return it raw, assuming it is already ok.
Otherwise cons up a path"
	path isEmpty ifTrue:[^pathName asSqueakPathName].
	((path includes: $$ ) or:[path includes: $:]) ifTrue:[^path].
	^pathName asSqueakPathName, self slash, path! !


!AcornFileDirectory methodsFor: 'path access' stamp: 'tpr 11/30/2003 21:42'!
pathParts
	"Return the path from the root of the file system to this directory as an 
	array of directory names.
	This version tries to cope with the RISC OS' strange filename formatting; 
	filesystem::discname/$/path/to/file
	where the $ needs to be considered part of the filingsystem-discname atom."
	| pathList |
	pathList := super pathParts.
	(pathList indexOf: '$') = 2
		ifTrue: ["if the second atom is root ($) then stick $ on the first atom 
				and drop the second. Yuck"
			^ Array
				streamContents: [:a | 
					a nextPut: (pathList at: 1), '/$'.
					3 to: pathList size do: [:i | a
								nextPut: (pathList at: i)]]].
	^ pathList! !


!AcornFileDirectory methodsFor: 'testing' stamp: 'tpr 4/28/2004 21:54'!
directoryExists: filenameOrPath
"if the path is a root,we have to treat it carefully"
	(filenameOrPath endsWith: '$') ifTrue:[^(FileDirectory on: filenameOrPath) exists].
	^(self directoryNamed: filenameOrPath ) exists! !


!AcornFileDirectory methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:31'!
directoryContentsFor: fullPath 
	"Return a collection of directory entries for the files and directories in 
	the directory with the given path. See primLookupEntryIn:index: for 
	further details."
	"FileDirectory default directoryContentsFor: ''"

	| entries extraPath |
	entries := super directoryContentsFor: fullPath.
	fullPath isNullPath
		ifTrue: [
			"For Acorn we also make sure that at least the parent of the current dir 
			is added - sometimes this is in a filing system that has not been (or 
			cannot be) polled for disc root names"
			extraPath := self class default containingDirectory.
			"Only add the extra path if we haven't already got the root of the current dir in the list"
			entries detect: [:ent | extraPath fullName beginsWith: ent name] 
				ifNone: [entries := entries
								copyWith: (DirectoryEntry
										name: extraPath fullName
										creationTime: 0
										modificationTime: 0
										isDirectory: true
										fileSize: 0)]].
	^ entries
! !

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

AcornFileDirectory class
	instanceVariableNames: ''!

!AcornFileDirectory class methodsFor: 'class initialization' stamp: 'stephaneducasse 2/4/2006 20:32'!
initialize
"Set up the legal chars map for filenames. May need extending for unicode etc.
Basic rule is that any char legal for use in filenames will have a non-nil entry in this array; except for space, this is the same character. Space is transcoded to a char 160 to be a 'hard space' "
"AcornFileDirectory initialize"
	| aVal |
	LegalCharMap := Array new: 256.
	Character alphabet do:[:c|
		LegalCharMap at: c asciiValue +1  put: c.
		LegalCharMap at: (aVal := c asUppercase) asciiValue +1 put: aVal].
	'`!!()-_=+[{]};~,./1234567890' do:[:c|
			LegalCharMap at: c asciiValue + 1 put: c].
	LegalCharMap at: Character space asciiValue +1 put: (Character value:160 "hardspace").
	LegalCharMap at: 161 put: (Character value:160 "hardspace")."secondary mapping to keep it in strings"! !


!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:16'!
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"

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

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'tpr 8/1/2003 16:38'!
isCaseSensitive
	"Risc OS ignores the case of file names"
	^ false! !

!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"
	^ $/
! !


!AcornFileDirectory class methodsFor: '*network-uri' stamp: 'tpr 5/4/2005 17:22'!
privateFullPathForURI: aURI
	"derive the full filepath from aURI"
	| first path |

	path _ String streamContents: [ :s |
		first := false.
		aURI pathComponents do: [ :p |
			first ifTrue: [ s nextPut: self pathNameDelimiter ].
			first _ true.
			s nextPutAll: p ] ].
	^path unescapePercents
! !
Array variableSubclass: #ActionSequence
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Object Events'!
!ActionSequence commentStamp: 'tlk 5/7/2006 20:02' prior: 0!
An ActionSequence is an array that lists the object's dependant objects.!


!ActionSequence methodsFor: 'converting' stamp: 'reThink 2/18/2001 15:12'!
asActionSequence

	^self! !

!ActionSequence methodsFor: 'converting' stamp: 'rw 7/20/2003 16:03'!
asActionSequenceTrappingErrors

	^WeakActionSequenceTrappingErrors withAll: self! !

!ActionSequence methodsFor: 'converting' stamp: 'reThink 2/18/2001 15:28'!
asMinimalRepresentation

	self size = 0
		ifTrue: [^nil].
	self size = 1
		ifTrue: [^self first].
	^self! !


!ActionSequence methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 17:51'!
value
    "Answer the result of evaluating the elements of the receiver."

    | answer |
    self do:
        [:each |
        answer := each value].
    ^answer! !

!ActionSequence methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 17:52'!
valueWithArguments: anArray

    | answer |
    self do:
        [:each |
        answer := each valueWithArguments: anArray].
    ^answer! !


!ActionSequence methodsFor: 'printing' stamp: 'SqR 07/28/2001 18:25'!
printOn: aStream

	self size < 2 ifTrue: [^super printOn: aStream].
	aStream nextPutAll: '#('.
	self
		do: [:each | each printOn: aStream]
		separatedBy: [aStream cr].
	aStream nextPut: $)! !
Object subclass: #ActorState
	instanceVariableNames: 'owningPlayer penDown penSize penColor fractionalPosition instantiatedUserScriptsDictionary penArrowheads trailStyle'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-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: 'filter streaming' 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'].
! !


!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: '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: 'pen' stamp: 'nk 6/12/2004 16:36'!
choosePenColor: evt
	owningPlayer costume changeColorTarget: owningPlayer costume selector: #penColor: originalColor: owningPlayer getPenColor 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: 'tk 10/4/2001 16:42'!
getPenArrowheads
	^ penArrowheads == true! !

!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: 'tk 10/4/2001 16:43'!
setPenArrowheads: aBoolean
	penArrowheads _ aBoolean! !

!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: 'pen' stamp: 'sw 4/16/2003 12:26'!
trailStyle
	"Answer the receiver's trailStyle.  For backward compatibility, if the old penArrowheads slot is in found to be set, use it as a guide for initialization"

	^ trailStyle ifNil: [trailStyle _ penArrowheads == true ifTrue: [#arrows] ifFalse: [#lines]]! !

!ActorState methodsFor: 'pen' stamp: 'sw 3/11/2003 11:28'!
trailStyle: aSymbol
	"Set the trail style to the given symbol"

	trailStyle _ aSymbol! !


!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: 'printing' 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: 'script instantiations' stamp: 'sw 4/9/98 22:35'!
instantiatedUserScriptsDictionary
	instantiatedUserScriptsDictionary ifNil: [instantiatedUserScriptsDictionary _ IdentityDictionary new].
	^ instantiatedUserScriptsDictionary! !
AbstractEvent subclass: #AddedEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Change Notification'!

!AddedEvent methodsFor: 'printing' stamp: 'rw 6/30/2003 09:31'!
printEventKindOn: aStream

	aStream nextPutAll: 'Added'! !


!AddedEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:35'!
isAdded

	^true! !

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

AddedEvent class
	instanceVariableNames: ''!

!AddedEvent class methodsFor: 'accessing' stamp: 'rw 7/19/2003 09:52'!
changeKind

	^#Added! !

!AddedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:22'!
supportedKinds
	"All the kinds of items that this event can take."
	
	^ Array with: self classKind with: self methodKind with: self categoryKind with: self protocolKind! !
EllipseMorph subclass: #AlertMorph
	instanceVariableNames: 'onColor offColor myObjSock socketOwner'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Audio Chat'!

!AlertMorph methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:25'!
color: aColor

	super color: aColor.
	onColor := aColor.! !

!AlertMorph methodsFor: 'accessing' stamp: 'mir 8/31/2004 15:47'!
onColor
	^onColor ifNil: [onColor := Color green]! !


!AlertMorph methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:25'!
socketOwner: aChatGUI

	socketOwner := aChatGUI.! !


!AlertMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:11'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 2! !

!AlertMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:11'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color red! !

!AlertMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:11'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self extent: 25 @ 25.
! !


!AlertMorph methodsFor: 'stepping and presenter' stamp: 'sd 11/20/2005 21:25'!
step

	super step.
	offColor ifNil: [offColor := self 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: 'testing' stamp: 'TBP 3/5/2000 13:47'!
stepTime
	"Answer the desired time between steps in milliseconds."

	^ 500! !


!AlertMorph methodsFor: 'visual properties' stamp: 'TBP 3/5/2000 13:47'!
canHaveFillStyles
	^false! !
RectangleMorph subclass: #AlignmentMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!AlignmentMorph commentStamp: 'kfr 10/27/2003 10:25' prior: 0!
Used for layout.
Since all morphs now support layoutPolicy the main use of this class is no longer needed.
Kept around for compability. 
Supports a few methods not found elsewhere that can be convenient, eg. newRow
!


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

	^ true
! !


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


!AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 0! !

!AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color
		r: 0.8
		g: 1.0
		b: 0.8! !

!AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:19'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self layoutPolicy: TableLayout new;
	 listDirection: #leftToRight;
	 wrapCentering: #topLeft;
	 hResizing: #spaceFill;
	 vResizing: #spaceFill;
	 layoutInset: 2;
	 rubberBandCells: true! !

!AlignmentMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:34'!
openInWindowLabeled: aString inWorld: aWorld

	self layoutInset: 0.
	^super openInWindowLabeled: aString inWorld: aWorld.! !


!AlignmentMorph methodsFor: 'object fileIn' stamp: 'gm 2/22/2003 13:12'!
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 isMorph 
		ifTrue: [(owner isAlignmentMorph) 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 isSystemWindow 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: 'objects from disk' stamp: 'tk 11/26/2004 05:51'!
convertToCurrentVersion: varDict refStream: smartRefStrm

	| newish |
	newish _ super convertToCurrentVersion: varDict refStream:
smartRefStrm.

	"major change - much of AlignmentMorph is now implemented
more generally in Morph"
	varDict at: 'hResizing' ifPresent: [ :x |
		^ newish convertOldAlignmentsNov2000: varDict using:
smartRefStrm].
	^ newish
! !


!AlignmentMorph methodsFor: 'visual properties' stamp: 'sw 11/5/2001 15:11'!
canHaveFillStyles
	"Return true if the receiver can have general fill styles; not just colors.
	This method is for gradually converting old morphs."

	^ self class == AlignmentMorph "no subclasses"! !


!AlignmentMorph methodsFor: '*eToys-e-toy support' stamp: 'panda 4/25/2000 15:44'!
configureForKids
	self disableDragNDrop.
	super configureForKids
! !


!AlignmentMorph methodsFor: '*eToys-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: '*MorphicExtras-initialization' stamp: 'dgd 2/14/2003 22:02'!
basicInitialize
	"Do basic generic initialization of the instance variables"
	super basicInitialize.
	""
	self layoutPolicy: TableLayout new;
	  listDirection: #leftToRight;
	  wrapCentering: #topLeft;
	  hResizing: #spaceFill;
	  vResizing: #spaceFill;
	  layoutInset: 2;
	  rubberBandCells: true! !

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

AlignmentMorph class
	instanceVariableNames: ''!

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'!
columnPrototype
	"Answer a prototypical column"

	| sampleMorphs aColumn |
	sampleMorphs _ #(red yellow green) collect:
		[:aColor | Morph new extent: 130 @ 38; color: (Color perform: aColor); setNameTo: aColor asString; yourself].
	aColumn _ self inAColumn: sampleMorphs.
	aColumn setNameTo: 'Column'.
	aColumn color: Color veryVeryLightGray.
	aColumn cellInset: 4; layoutInset: 6.
	aColumn enableDragNDrop.
	aColumn setBalloonText: 'Things dropped into here will automatically be organized into a column. Once you have added your own items here, you will want to remove the sample colored rectangles that this started with, and you will want to change this balloon help message to one of your own!!' translated.
	^ aColumn! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/2/2001 04:45'!
inAColumn: aCollectionOfMorphs
	"Answer a columnar AlignmentMorph holding the given collection"

	| col |
	col _ self newColumn
		color: Color transparent;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		layoutInset: 1;
		borderColor: Color black;
		borderWidth: 1;
		wrapCentering: #center;
		cellPositioning: #topCenter.
	aCollectionOfMorphs do: [:each | col addMorphBack: each].
	^ col! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/5/2001 15:11'!
inARow: aCollectionOfMorphs
	"Answer a row-oriented AlignmentMorph holding the given collection"

	| aRow |
	aRow _ self newRow
		color: Color transparent;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		layoutInset: 1;
		borderColor: Color black;
		borderWidth: 1;
		wrapCentering: #center;
		cellPositioning: #topCenter.
	aCollectionOfMorphs do: [ :each | aRow addMorphBack: each].
	^ aRow! !

!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 class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'!
rowPrototype
	"Answer a prototypical row"

	| sampleMorphs aRow |
	sampleMorphs _ (1 to: (2 + 3 atRandom)) collect:
		[:integer | EllipseMorph new extent: ((60 + (20 atRandom)) @ (80 + ((20 atRandom)))); color: Color random; setNameTo: ('egg',  integer asString); yourself].
	aRow _ self inARow: sampleMorphs.
	aRow setNameTo: 'Row'.
	aRow enableDragNDrop.
	aRow cellInset: 6.
	aRow layoutInset: 8.
	aRow setBalloonText: 'Things dropped into here will automatically be organized into a row. Once you have added your own items here, you will want to remove the sample colored eggs that this started with, and you will want to change this balloon help message to one of your own!!' translated.
	aRow color: Color veryVeryLightGray.
	^ aRow

			"AlignmentMorph rowPrototype openInHand"! !


!AlignmentMorph class methodsFor: 'scripting' stamp: 'sw 11/16/2004 00:44'!
defaultNameStemForInstances
	"The code just below, now commented out, resulted in every instance of every sublcass of AlignmentMorph being given a default name of the form 'Alignment1', rather than the desired 'MoviePlayer1', 'ScriptEditor2', etc."

	"^ 'Alignment'"

	^ super defaultNameStemForInstances! !


!AlignmentMorph class methodsFor: '*eToys-scripting' stamp: 'sw 11/16/2001 10:01'!
additionsToViewerCategories
	"Answer viewer additions for the 'layout' category"

	^#((
		layout 
		(
			(slot cellInset 'The cell inset' Number readWrite Player getCellInset Player setCellInset:)
			(slot layoutInset 'The layout inset' Number readWrite Player getLayoutInset Player setLayoutInset:)
			(slot listCentering 'The list centering' ListCentering readWrite Player getListCentering Player setListCentering:)
			(slot hResizing  	'Horizontal resizing' Resizing readWrite Player 	getHResizing Player setHResizing:)
			(slot vResizing  	'Vertical resizing' Resizing readWrite Player 	getVResizing Player setVResizing:)
			(slot listDirection  'List direction' ListDirection readWrite Player 	getListDirection Player setListDirection:)
			(slot wrapDirection 'Wrap direction' ListDirection readWrite Player 	getWrapDirection Player setWrapDirection:)
		)))
! !


!AlignmentMorph class methodsFor: '*MorphicExtras-parts bin' stamp: 'sw 11/16/2001 09:16'!
supplementaryPartsDescriptions
	"Extra items for parts bins"

	^ {DescriptionForPartsBin
		formalName: 'Column'
		categoryList: #('Presentation')
		documentation: 'An object that presents the things within it in a column'
		globalReceiverSymbol: #AlignmentMorph
		nativitySelector: #columnPrototype.
	DescriptionForPartsBin
		formalName: 'Row'
		categoryList: #('Presentation')
		documentation: 'An object that presents the things within it in a row'
		globalReceiverSymbol: #AlignmentMorph
		nativitySelector: #rowPrototype}! !
AlignmentMorph subclass: #AlignmentMorphBob1
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalSupport'!
!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 3/10/2001 13:54'!
acceptDroppingMorph: aMorph event: evt

	| handlerForDrops |

	handlerForDrops _ self valueOfProperty: #handlerForDrops ifAbsent: [
		^super acceptDroppingMorph: aMorph event: evt
	].
	(handlerForDrops acceptDroppingMorph: aMorph event: evt in: self) ifFalse: [
		aMorph rejectDropMorphEvent: evt.		"send it back where it came from"
	].! !

!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: 'dgd 11/7/2004 19:52'!
addARowCentered: aCollectionOfMorphs cellInset: cellInsetInteger

	^(self addARow: aCollectionOfMorphs)
		hResizing: #shrinkWrap;
		wrapCentering: #center;
		cellPositioning: #leftCenter;
		cellInset: cellInsetInteger! !

!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: 'dgd 11/3/2004 19:28'!
fancyText: aString font: aFont color: aColor 
	| answer tm col |
	col := ColorTheme current dialog3DTitles
				ifTrue: [aColor]
				ifFalse: [aColor negated].
	tm := TextMorph new.
	tm beAllFont: aFont;
		 color: col;
		 contents: aString.
	answer := self inAColumn: {tm}.
	ColorTheme current dialog3DTitles
		ifTrue: [""
			tm addDropShadow.
			tm shadowPoint: 5 @ 5 + tm bounds center].
	tm lock.
	^ answer! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'ar 12/30/2001 19:14'!
fullDrawOn: aCanvas

	| mask |
	(aCanvas isVisible: self fullBounds) ifFalse:[^self].
	super fullDrawOn: aCanvas.
	mask _ self valueOfProperty: #disabledMaskColor ifAbsent: [^self].
	aCanvas fillRectangle: bounds color: mask.
! !

!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: 'dgd 11/2/2004 21:54'!
inARightColumn: aCollectionOfMorphs 
	| col |
	col := AlignmentMorph newColumn color: Color transparent;
				 vResizing: #shrinkWrap;
				 layoutInset: 1;
				 wrapCentering: #bottomRight;
				 cellPositioning: #topCenter.
	aCollectionOfMorphs
		do: [:each | col addMorphBack: each].
	^ col! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'dgd 4/4/2006 16:16'!
inARow: aCollectionOfMorphs 
	| row |
	row := AlignmentMorph newRow color: Color transparent;
				 vResizing: #shrinkWrap;
				 layoutInset: 2;
				 wrapCentering: #center;
				 cellPositioning: #leftCenter.
	aCollectionOfMorphs
		do: [:each | row addMorphBack: each].
	^ row! !

!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

! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'RAA 3/14/2001 08:36'!
wantsDroppedMorph: aMorph event: evt

	| handlerForDrops |

	handlerForDrops _ self valueOfProperty: #handlerForDrops ifAbsent: [
		^super wantsDroppedMorph: aMorph event: evt
	].
	^handlerForDrops wantsDroppedMorph: aMorph event: evt in: self! !


!AlignmentMorphBob1 methodsFor: 'initialization' stamp: 'dgd 4/4/2006 16:17'!
initialize
	super initialize.
	self listDirection: #topToBottom.
	self layoutInset: 0.
	self hResizing: #rigid. "... this is very unlikely..."
	self vResizing: #rigid! !
AlignmentMorph subclass: #AllPlayersTool
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!AllPlayersTool commentStamp: '<historical>' prior: 0!
A tool that lets you see find, view, and obtain tiles for all the active players in the project.!


!AllPlayersTool methodsFor: 'initialization' stamp: 'sw 12/8/2004 11:12'!
addHeaderRow
	"Add the header morph at the top of the tool"

	| aRow title aButton |
	aRow _ AlignmentMorph newRow.
	aRow listCentering: #justified; color: Color transparent.
	aButton _ self tanOButton.
	aButton actionSelector: #delete.
	aRow addMorphFront: aButton.
	aRow addMorphBack: (title _ StringMorph contents: 'Gallery of Players' translated).
	title setBalloonText: 'Double-click here to refresh the contents' translated.
	title on: #doubleClick send: #reinvigorate to: self.
	aRow addMorphBack: self helpButton.
	self addMorphFront: aRow.
! !

!AllPlayersTool methodsFor: 'initialization' stamp: 'sw 7/28/2004 20:48'!
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 scope of the containing pasteup's presenter"

	| placeHolder |
	self color: Color brown muchLighter muchLighter; wrapCentering: #center; cellPositioning: #topCenter; vResizing: #shrinkWrap; hResizing: #shrinkWrap.
	self useRoundedCorners.
	self borderStyle: BorderStyle complexAltInset; borderWidth: 4; borderColor: (Color r: 0.452 g: 0.839 b: 1.0).  "Color fromUser"
	self addHeaderRow.
	placeHolder _ Morph new beTransparent.
	placeHolder extent: 200@1.
	self addMorphBack: placeHolder.
	ActiveWorld presenter reinvigoratePlayersTool: self 

! !

!AllPlayersTool methodsFor: 'initialization' stamp: 'sw 7/28/2004 18:08'!
initializeToStandAlone
	"Initialize the receiver"

	super initializeToStandAlone.
	self layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		hResizing: #spaceFill;
		extent: 1@1;
		vResizing: #spaceFill;
		rubberBandCells: true;
		yourself.

	self initializeFor: self currentWorld presenter! !


!AllPlayersTool methodsFor: 'menus' stamp: 'sw 7/28/2004 18:32'!
addCustomMenuItems: aMenu hand: aHand
	"Add further items to the menu"

	aMenu add: 'reinvigorate' target: self action: #reinvigorate.
	Preferences eToyFriendly ifFalse: [aMenu add: 'inspect' target: self action: #inspect]! !

!AllPlayersTool methodsFor: 'menus' stamp: 'sw 7/28/2004 22:58'!
presentHelp
	"Sent when a Help button is hit; provide the user with some form of help for the tool at hand"

	| aString aTextMorph |
	aString _ 'About the Gallery of Players

Click on an object''s picture to reveal its location.
Click on the turquoise eye to open the object''s viewer.
Click on an object''s name to obtain a tile representing the object.   

Double-click on the title ("Gallery of Players") to refresh the tool;
this may allow you to see newly-added or newly-scripted objects.'.
	aTextMorph _  TextMorph new contents: aString translated.
	aTextMorph useRoundedCorners; borderWidth: 3; borderColor: Color gray; margins: 3@3.
	aTextMorph backgroundColor: Color blue muchLighter.
	aTextMorph beAllFont: (StrikeFont familyName: #ComicBold size: 18);
	 centered; lock.
	AlignmentMorph new beTransparent
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		addMorphBack: aTextMorph;
		openInHand! !


!AllPlayersTool methodsFor: 'reinvigoration' stamp: 'sw 7/19/2004 16:37'!
invigorateButton
	"Answer a button that triggers reinvigoration"

	| aButton |
	aButton _ IconicButton new target: self;
		borderWidth: 0;
		labelGraphic: (ScriptingSystem formAtKey: #Refresh);
		color: Color transparent; 
		actWhen: #buttonUp;
		actionSelector: #reinvigorate;
		yourself.
	aButton setBalloonText: 'Click here to refresh the list of players'.
	^ aButton
! !

!AllPlayersTool methodsFor: 'reinvigoration' stamp: 'sw 7/19/2004 16:17'!
menuButton
	"Answer a button that brings up a menu.  Useful when adding new features, but at present is between uses"

	| aButton |
	aButton _ IconicButton new target: self;
		borderWidth: 0;
		labelGraphic: (ScriptingSystem formAtKey: #TinyMenu);
		color: Color transparent; 
		actWhen: #buttonDown;
		actionSelector: #offerMenu;
		yourself.
	aButton setBalloonText: 'click here to get a menu with further options'.
	^ aButton
! !

!AllPlayersTool methodsFor: 'reinvigoration' stamp: 'sw 7/28/2004 18:08'!
reinvigorate
	"Referesh the contents of the receiver"

	(submorphs copyFrom: 3 to: submorphs size) do:
		[:m | m delete].
	ActiveWorld doOneCycleNow.
	self playSoundNamed: 'scritch'.
	(Delay forMilliseconds: 700) wait.
	ActiveWorld presenter reinvigoratePlayersTool: self.
	self playSoundNamed: 'scratch'! !

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

AllPlayersTool class
	instanceVariableNames: ''!

!AllPlayersTool class methodsFor: 'instance-creation defaults' stamp: 'sw 7/19/2004 10:38'!
defaultNameStemForInstances
	"Answer the default name stem for new instances of this class"

	^ 'Players'! !


!AllPlayersTool class methodsFor: 'parts bin' stamp: 'sw 7/19/2004 10:37'!
descriptionForPartsBin
	"Answer a description for use in parts bins"

	^ self partName: 	'Players'
		categories:		#('Scripting')
		documentation:	'A tool showing all the players in your project'! !
AlignmentMorph subclass: #AllScriptsTool
	instanceVariableNames: 'showingOnlyActiveScripts showingAllInstances showingOnlyTopControls'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting'!
!AllScriptsTool commentStamp: '<historical>' prior: 0!
A tool for controlling and viewing all scripts in a project.  The tool has an open and a closed form.  In the closed form, stop-step-go buttons are available, plus a control for opening the tool up.  In the open form, it has a second row of controls that govern which scripts should be shown, followed by the individual script items.!


!AllScriptsTool methodsFor: 'initialization' stamp: 'dgd 9/19/2003 14:34'!
addSecondLineOfControls
	"Add the second line of controls"

	| aRow outerButton aButton worldToUse |
	aRow _ AlignmentMorph newRow listCentering: #center; color: Color transparent.
	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 addTransparentSpacerOfSize: (4@0).
	outerButton addMorphBack: (StringMorph contents: 'tickers only' translated) lock.
	outerButton setBalloonText: 'If checked, then only scripts that are paused or ticking will be shown' translated.
	aRow addMorphBack: outerButton.

	aRow addTransparentSpacerOfSize: 20@0.
	aRow addMorphBack: self helpButton.

	aRow addTransparentSpacerOfSize: 20@0.

	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 addTransparentSpacerOfSize: (4@0).
	outerButton addMorphBack: (StringMorph contents: 'all instances' translated) lock.
	outerButton setBalloonText: 'If checked, then entries for all instances will be shown, but if not checked, scripts for only one representative of each different kind of object will be shown.  Consult the help available by clicking on the purple ? for more information.' translated.
	aRow addMorphBack: outerButton.

	self addMorphBack: aRow.
	worldToUse _ self isInWorld ifTrue: [self world] ifFalse: [ActiveWorld].
	worldToUse presenter reinvigorateAllScriptsTool: self.
	self layoutChanged.! !

!AllScriptsTool methodsFor: 'initialization' stamp: 'dgd 8/31/2003 19:43'!
dismissButton
	"Answer a button whose action would be to dismiss the 
	receiver "
	| aButton |
	aButton := super dismissButton.
	aButton setBalloonText: 'Click here to remove this tool from the screen; you can get another one any time you want from the Widgets flap' translated.
	^ aButton! !

!AllScriptsTool methodsFor: 'initialization' stamp: 'sw 12/8/2004 11:26'!
initializeFor: ignored
	"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 scope of the containing pasteup's presenter"

	| aRow aButton |
	showingOnlyActiveScripts _ true.
	showingAllInstances _ true.
	showingOnlyTopControls _ true.
	self color: Color brown muchLighter muchLighter; wrapCentering: #center; cellPositioning: #topCenter; vResizing: #shrinkWrap; hResizing: #shrinkWrap.
	self useRoundedCorners.
	self borderWidth: 4; borderColor: Color brown darker.
	aRow _ AlignmentMorph newRow.
	aRow listCentering: #justified; color: Color transparent.
	aButton _ self tanOButton.
	aButton actionSelector: #delete.
	aRow addMorphFront: aButton.
	aRow addMorphBack: ScriptingSystem scriptControlButtons.
	aRow addMorphBack: self openUpButton.
	self addMorphFront: aRow.

! !

!AllScriptsTool methodsFor: 'initialization' stamp: 'dgd 9/19/2003 14:35'!
presentHelp
	"Sent when a Help button is hit; provide the user with some form of help for the tool at hand"

	| aString |
	aString _ 
'This tool allows you to see all the scripts for all the objects in this project.

Sometimes you are only interested in those scripts that are ticking, or that are *ready* to tick when you hit the GO button (which are said to be "paused.")

Check "tickers only" if you only want to see such scripts -- i.e., scripts that are either paused or ticking.

If "tickers only" is *not* checked, then all scripts will be shown, whatever their status.

The other checkbox, labeled "all instances", only comes into play if you have created "multiple sibling instances" (good grief) of the same object, which share the same scripts; if you have such things, it is often convenient to see the scripts of just *one* such sibling, because it will take up less space and require less mindshare -- and note that you can control a script for an object *and* all its siblings from the menu of that one that you see, via menu items such as "propagate status to siblings".

If "all instances" is checked, scripts for all sibling instances will be shown, whereas if "all instances" is *not* checked, only one of each group of siblings will be selected to have its scripts shown.

But how do you get "multiple sibling instances" of the same object?  There are several ways:

(1)  Use the "make a sibling instance" or the "make multiple siblings..." menu item in the halo menu of a scripted object

(2)  Use the "copy" tile in a script.

(3)  Request "give me a copy now" from the menu associated with the "copy" item in a Viewer

If you have on your screen multiple sibling instances of the same object, then you may or may want to see them all in the All Scripts tool, and that is what the "all instances" checkbox governs.

Set "all instances" if you want a separate entry for each instance, as
opposed to a single representative of that kind of object.

Note that if you obtain a copy of an object by using the green halo handle, it will *not* be a sibling instance of the original.  It will in many ways seem to be, because it will start out its life having the same scripts as the original.  But it will then lead an independent life, so that changes to scripts of the original will not be reflected in it, and vice-versa.

This is an important distinction, and an unavoidable one because people sometimes want the deep sharing of sibling instances and sometimes they clearly do not.  But the truly understandable description of these concepts and distinctions certainly lies *ahead* of us!!'.

	(StringHolder new contents: aString translated)
		openLabel: 'About the All Scripts tool' translated! !


!AllScriptsTool methodsFor: 'parts bin' stamp: 'dgd 2/22/2003 19:37'!
initializeToStandAlone
	super initializeToStandAlone.
	self
		layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		hResizing: #spaceFill;
		extent: 1 @ 1;
		vResizing: #spaceFill;
		rubberBandCells: true.
	self initializeFor: self currentWorld presenter! !


!AllScriptsTool methodsFor: 'stepping and presenter' stamp: 'sw 11/14/2001 00:31'!
step
	"If the list of scripts to show has changed, refresh my contents"

	self showingOnlyTopControls ifFalse:
		[self presenter reinvigorateAllScriptsTool: self].! !


!AllScriptsTool methodsFor: 'testing' stamp: 'sw 1/31/2001 23:12'!
stepTime
	"Answer the interval between steps -- in this case a leisurely 4 seconds"

	^ 4000! !

!AllScriptsTool methodsFor: 'testing' stamp: 'sw 1/31/2001 23:12'!
wantsSteps
	"Answer whether the receiver wishes to receive the #step message"

	 ^ true! !


!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 12/8/2004 11:28'!
openUpButton
	"Answer a button whose action would be to open up the receiver or snap it back closed"

	| aButton aForm |
	aButton _ IconicButton new borderWidth: 0.
	aForm _ ScriptingSystem formAtKey: #PowderBlueOpener.
	aForm ifNil:
		[aForm _ Form extent: 13@22 depth: 16 fromArray: #( 0 0 12017 787558129 0 0 0 0 12017 787561309 995965789 787558129 0 0 0 787561309 995965789 995965789 995965789 787546112 0 12017 995965789 995965789 995965789 995965789 995962609 0 12017 995965789 995965789 995965789 995965789 995962609 0 787561309 995965789 995965789 995965789 995965789 995965789 787546112 787561309 995965789 995965789 995965789 995965789 995965789 787546112 787561309 995965789 995950593 80733 995965789 995965789 787546112 787561309 995965789 65537 65537 80733 995965789 787546112 787561309 995950593 80733 995950593 80733 995965789 787546112 787561309 995950593 80733 995950593 80733 995965789 787546112 787561309 995950593 65537 65537 80733 995965789 787546112 787561309 995965789 65537 65537 995965789 995965789 787546112 787561309 995965789 995965789 995965789 995965789 995965789 787546112 787561309 995965789 995965789 995965789 995965789 995965789 787546112 787561309 995965789 995965789 995965789 995965789 995965789 787546112 787561309 995965789 995965789 995965789 995965789 995965789 787546112 12017 995965789 995965789 995965789 995965789 995962609 0 12017 995965789 995965789 995965789 995965789 995962609 0 0 787561309 995965789 995965789 995965789 787546112 0 0 12017 787561309 995965789 787558129 0 0 0 0 12017 787558129 0 0 0) offset: 0@0.
		ScriptingSystem saveForm: aForm atKey: #PowderBlueOpener].
	aButton labelGraphic: aForm.
	aButton
		target: self;
		color: Color transparent;
		actionSelector: #toggleWhetherShowingOnlyTopControls;
		setBalloonText: 'open or close the lower portion that shows individual scripts' translated.
	^ aButton! !

!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 11/13/2001 19:43'!
showingOnlyTopControls
	"Answer whether the receiver is currently showing only the top controls"
 
	^ showingOnlyTopControls ifNil: [showingOnlyTopControls _ true]! !

!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/14/2001 00:32'!
toggleWhetherShowingAllInstances
	"Toggle whether the receiver is showing all instances or only one exemplar per uniclass"

	showingAllInstances _ showingAllInstances not.
	self presenter reinvigorateAllScriptsTool: self! !

!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/14/2001 00:32'!
toggleWhetherShowingOnlyActiveScripts
	"Toggle whether the receiver is showing only active scripts"

	showingOnlyActiveScripts _ showingOnlyActiveScripts not.
	self presenter reinvigorateAllScriptsTool: self! !

!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/14/2001 00:32'!
toggleWhetherShowingOnlyTopControls
	"Toggle whether the receiver is showing only the stop/step/go line or the full whammy"

	| aCenter |
	showingOnlyTopControls _ self showingOnlyTopControls not.
	aCenter _ self center x.
	self showingOnlyTopControls
		ifTrue:
			[self removeAllButFirstSubmorph]
		ifFalse:
			[self addSecondLineOfControls.
			self presenter reinvigorateAllScriptsTool: self].
	WorldState addDeferredUIMessage:
		[self center: (aCenter @ self center y)]
	! !

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

AllScriptsTool class
	instanceVariableNames: ''!

!AllScriptsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:28'!
initialize

	self registerInFlapsRegistry.	! !

!AllScriptsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:30'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(AllScriptsTool			allScriptsToolForActiveWorld	'All Scripts' 		'A tool that lets you see and control all the running scripts in your project')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(AllScriptsTool			allScriptsToolForActiveWorld	'All Scripts' 		'A tool that lets you control all the running scripts in your world')
						forFlapNamed: 'Scripting'.
						cl registerQuad: #(AllScriptsTool			allScriptsToolForActiveWorld	'All Scripts' 		'A tool that lets you see and control all the running scripts in your project')
						forFlapNamed: 'Widgets']! !

!AllScriptsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:30'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!AllScriptsTool class methodsFor: 'instance creation' stamp: 'sw 6/12/2001 11:52'!
allScriptsToolForActiveWorld
	"Launch an AllScriptsTool to view scripts of the active world"

	| aTool |
	aTool _ self newColumn.
	aTool initializeFor: ActiveWorld presenter.
	^ aTool! !

!AllScriptsTool class methodsFor: 'instance creation' 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
! !


!AllScriptsTool class methodsFor: 'parts bin' stamp: 'sw 11/13/2001 18:31'!
descriptionForPartsBin
	"Answer a description for use in parts bins"

	^ self partName: 	'All Scripts'
		categories:		#('Scripting')
		documentation:	'A tool allowing you to monitor and change the status of all scripts in your project'! !


!AllScriptsTool class methodsFor: 'printing' stamp: 'sw 11/13/2001 19:44'!
defaultNameStemForInstances
	"Answer the default name stem for new instances of this class"

	^ 'All Scripts'! !
ColorMappingCanvas subclass: #AlphaBlendingCanvas
	instanceVariableNames: 'alpha'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'!
alpha
	^alpha! !

!AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'!
alpha: newAlpha
	alpha _ newAlpha.! !


!AlphaBlendingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:18'!
on: aCanvas
	myCanvas _ aCanvas.
	alpha _ 1.0.! !


!AlphaBlendingCanvas methodsFor: 'private' stamp: 'bf 10/28/2003 15:46'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	"Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle."
	rule = Form paint ifTrue:[
		^myCanvas
			image: aForm
			at: aPoint
			sourceRect: sourceRect
			rule: Form paintAlpha
			alpha: alpha.
	].
	rule = Form over ifTrue:[
		^myCanvas
			image: aForm
			at: aPoint
			sourceRect: sourceRect
			rule: Form blendAlpha
			alpha: alpha.
	].! !

!AlphaBlendingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:23'!
mapColor: aColor
	aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..."
	aColor isTransparent ifTrue:[^aColor].
	aColor isOpaque ifTrue:[^aColor alpha: alpha].
	^aColor alpha: (aColor alpha * alpha)! !
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: 'stephaneducasse 2/4/2006 20:40'!
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: 'stephaneducasse 2/4/2006 20:40'!
target: t selector: s arguments: a
	target := t.
	selector := s.
	arguments := a.
! !
GIFReadWriter subclass: #AnimatedGIFReadWriter
	instanceVariableNames: 'forms delays comments'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Files'!

!AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'bf 2/25/2005 11:11'!
allImages
	| body colorTable |
	stream class == ReadWriteStream ifFalse: [
		stream binary.
		self on: (ReadWriteStream with: (stream contentsOfEntireFile))].
	localColorTable _ nil.
	forms _ OrderedCollection new.
	delays _ OrderedCollection new.
	comments _ OrderedCollection new.
	self readHeader.
	[(body _ self readBody) == nil]
		whileFalse: [colorTable _ localColorTable
						ifNil: [colorPalette].
			transparentIndex
				ifNotNil: [transparentIndex + 1 > colorTable size
						ifTrue: [colorTable _ colorTable forceTo: transparentIndex + 1 paddingWith: Color white].
					colorTable at: transparentIndex + 1 put: Color transparent].
			body colors: colorTable.
			forms add: body.
			delays add: delay].
	^ forms! !

!AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'!
delays
	^ delays! !

!AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'!
forms
	^ forms! !


!AnimatedGIFReadWriter methodsFor: 'private' stamp: 'mir 11/19/2003 12:25'!
comment: aString
	comments add: aString! !


!AnimatedGIFReadWriter methodsFor: 'private-decoding' stamp: 'mir 11/19/2003 12:21'!
readBitData
	| form |
	form := super readBitData.
	form offset: offset.
	^form! !

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

AnimatedGIFReadWriter class
	instanceVariableNames: ''!

!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'mir 11/18/2003 17:00'!
formsFromFileNamed: fileName 
	| stream |
	stream _ FileStream readOnlyFileNamed: fileName.
	^ self formsFromStream: stream! !

!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'mir 11/18/2003 17:00'!
formsFromStream: stream 
	| reader |
	reader _ self new on: stream reset.
	Cursor read
		showWhile: [reader allImages.
			reader close].
	^reader! !

!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 6/12/2004 13:12'!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"
	^#('gif')! !

!AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'!
wantsToHandleGIFs
	^true! !
ImageMorph subclass: #AnimatedImageMorph
	instanceVariableNames: 'images delays stepTime nextTime imageIndex'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalMorphs'!
!AnimatedImageMorph commentStamp: '<historical>' prior: 0!
I am an ImageMorph that can hold more than one image. Each image has its own delay time.!


!AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'bf 2/25/2005 11:06'!
step
	| f d |
	images isEmpty
		ifTrue: [^ self].
	nextTime > Time millisecondClockValue
		ifTrue: [^self].
	imageIndex _ imageIndex \\ images size + 1.
	f _ images at: imageIndex.
	f displayOn: self image at: 0@0 rule: Form paint.
	self invalidRect: (self position + f offset extent: f extent).
	d _ (delays at: imageIndex) ifNil: [0].
	nextTime := Time millisecondClockValue + d
! !

!AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'mir 11/19/2003 13:40'!
stepTime
	^stepTime ifNil: [super stepTime]! !

!AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'mir 11/19/2003 13:40'!
stepTime: anInteger
	stepTime _ anInteger! !

!AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'asm 12/15/2003 19:44'!
wantsSteps
	^(images size > 1)
! !


!AnimatedImageMorph methodsFor: 'private' stamp: 'nk 2/15/2004 15:20'!
fromGIFFileNamed: fileName
	self fromReader: (AnimatedGIFReadWriter formsFromFileNamed: fileName)! !

!AnimatedImageMorph methodsFor: 'private' stamp: 'bf 2/25/2005 11:18'!
fromReader: reader
	images _ reader forms.
	delays _ reader delays.
	imageIndex _ 0.
	self image: (Form extent: images first extent depth: 32).
	self step! !

!AnimatedImageMorph methodsFor: 'private' stamp: 'nk 2/15/2004 15:20'!
fromStream: aStream
	self fromReader: (AnimatedGIFReadWriter formsFromStream: aStream)! !

!AnimatedImageMorph methodsFor: 'private' stamp: 'mir 11/19/2003 13:42'!
images
	^images! !

!AnimatedImageMorph methodsFor: 'private' stamp: 'bf 2/25/2005 11:09'!
initialize
	nextTime := Time millisecondClockValue.
	imageIndex := 1.
	stepTime := 10.
	super initialize! !

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

AnimatedImageMorph class
	instanceVariableNames: ''!

!AnimatedImageMorph class methodsFor: 'class initialization' stamp: 'asm 12/11/2003 21:05'!
initialize
	"register the receiver in the global registries"
	self environment
		at: #FileList
		ifPresent: [:cl | cl registerFileReader: self]! !

!AnimatedImageMorph class methodsFor: 'class initialization' stamp: 'asm 12/11/2003 21:01'!
unload
	"Unload the receiver from global registries"
	self environment
		at: #FileList
		ifPresent: [:cl | cl unregisterFileReader: self]! !


!AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'nk 6/12/2004 13:11'!
fileReaderServicesForFile: fullName suffix: suffix

	^((AnimatedGIFReadWriter typicalFileExtensions asSet
		add: '*'; add: 'form'; yourself)
		includes: suffix)
		ifTrue: [ self services ]
		ifFalse: [#()]
! !

!AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'dgd 4/3/2006 13:36'!
serviceOpenGIFInWindow
	"Answer a service for opening a gif graphic in a window"
	^ (SimpleServiceEntry
		provider: self
		label: 'open the graphic as a morph'
		selector: #openGIFInWindow:
		description: 'open a GIF graphic file as a morph'
		buttonLabel: 'open')
		argumentGetter: [:fileList | fileList readOnlyStream]! !

!AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'dgd 4/3/2006 13:36'!
services
	^ Array
		with: self serviceOpenGIFInWindow
		"with: Form serviceImageImports"
		with: Form serviceImageAsBackground! !


!AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 15:23'!
fromGIFFileNamed: fileName
	| reader |
	reader _ AnimatedGIFReadWriter formsFromFileNamed: fileName.
	^reader forms size = 1
		ifTrue: [ ImageMorph new image: reader forms first ]
		ifFalse: [ self new fromReader: reader ]! !

!AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 15:27'!
fromStream: aStream
	| reader |
	reader _ AnimatedGIFReadWriter formsFromStream: aStream.
	^reader forms size = 1
		ifTrue: [ ImageMorph new image: reader forms first ]
		ifFalse: [ self new fromReader: reader ]! !

!AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 16:57'!
openGIFInWindow: aStream
	^(self fromStream: aStream binary) openInWorld! !
StarSqueakTurtle subclass: #AntColonyTurtle
	instanceVariableNames: 'isCarryingFood pheromoneDropSize'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'StarSqueak-Worlds'!

!AntColonyTurtle methodsFor: 'demons' stamp: 'sd 11/20/2005 21:26'!
dropFoodInNest

	(isCarryingFood and: [(self get: 'isNest') > 0]) ifTrue: [
		self color: Color black.
		isCarryingFood := false.
		"turn around and go forward to try to pick up pheromone trail"
		self turnRight: 180.
		self forward: 3].
! !

!AntColonyTurtle methodsFor: 'demons' stamp: 'sd 11/20/2005 21:26'!
pickUpFood

	| newFood |
	(isCarryingFood not and: [(self get: 'food') > 0]) ifTrue: [
		newFood := (self get: 'food') - 1.
		self set: 'food' to: newFood.
		newFood = 0 ifTrue: [self patchColor: world backgroundColor].
		isCarryingFood := true.
		pheromoneDropSize := 800.
		self color: Color red.

		"drop a blob of pheromone on the side of the food farthest from nest"
		self turnTowardsStrongest: 'nestScent'.
		self turnRight: 180.
		self forward: 4.
		self increment: 'pheromone' by: 5000].
! !

!AntColonyTurtle methodsFor: 'demons' stamp: 'sd 11/20/2005 21:26'!
returnToNest

	isCarryingFood ifTrue: [
		"decrease size of pheromone drops to create a gradient back to food"
		pheromoneDropSize > 0 ifTrue: [
			self increment: 'pheromone' by: pheromoneDropSize.
			pheromoneDropSize := pheromoneDropSize - 20].
		self turnTowardsStrongest: 'nestScent'.
		self forward: 1].
! !

!AntColonyTurtle methodsFor: 'demons' stamp: 'jm 2/7/2001 08:12'!
searchForFood
	"If you smell pheromone, go towards the strongest smell. Otherwise, wander aimlessly."

	isCarryingFood ifFalse: [
		((self get: 'pheromone') > 1)
			ifTrue: [self turnTowardsStrongest: 'pheromone']
			ifFalse: [
				self turnRight: (self random: 40).
				self turnLeft: (self random: 40)].
		self forward: 1].
! !


!AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:24'!
isCarryingFood

	^ isCarryingFood
! !

!AntColonyTurtle methodsFor: 'variables' stamp: 'sd 11/20/2005 21:26'!
isCarryingFood: aBoolean

	isCarryingFood := aBoolean.
! !

!AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:24'!
pheromoneDropSize

	^ pheromoneDropSize
! !

!AntColonyTurtle methodsFor: 'variables' stamp: 'sd 11/20/2005 21:26'!
pheromoneDropSize: aNumber

	pheromoneDropSize := aNumber.
! !
Object subclass: #AppRegistry
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Applications'!
!AppRegistry commentStamp: 'ads 4/2/2003 15:30' prior: 0!
AppRegistry is a simple little class, not much more than a wrapper around a collection. It's intended to help break dependencies between packages. For example, if you'd like to be able to send e-mail, you could use the bare-bones MailComposition class, or you could use the full-blown Celeste e-mail client. Instead of choosing one or the other, you can call "MailSender default" (where MailSender is a subclass of AppRegistry), and thus avoid creating a hard-coded dependency on either of the two mail senders.

This will only really be useful, of course, for applications that have a very simple, general, well-defined interface. Most of the time, you're probably better off just marking your package as being dependent on a specific other package, and avoiding the hassle of this whole AppRegistry thing. But for simple things like e-mail senders or web browsers, it might be useful.
!


!AppRegistry methodsFor: 'notes' stamp: 'ads 4/2/2003 15:04'!
seeClassSide
	"All the code for AppRegistry is on the class side."! !

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

AppRegistry class
	instanceVariableNames: 'registeredClasses default'!

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:36'!
appName
	"Defaults to the class name, which is probably good enough, but you could override this in subclasses if you want to."
	^ self name! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'md 12/1/2004 23:58'!
askForDefault
	| menu |
	self registeredClasses isEmpty ifTrue:
		[self inform: 'There are no ', self appName, ' applications registered.'.
		^ default _ nil].
	self registeredClasses size = 1 ifTrue:
		[^ default _ self registeredClasses anyOne].
	
	menu _ CustomMenu new.
	self registeredClasses do: [:c | menu add: c name printString action: c].
	default _  menu startUpWithCaption: 'Which ', self appName, ' would you prefer?'.
	default ifNil: [default := self registeredClasses first].
	^default.! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:11'!
default
	^ default ifNil: [self askForDefault]! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'nk 3/9/2004 12:33'!
default: aClassOrNil
	"Sets my default to aClassOrNil. 
	Answers the old default."
	| oldDefault |
	oldDefault := default.
	aClassOrNil ifNotNil: [ self register: aClassOrNil ].
	default := aClassOrNil.
	^ oldDefault! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'nk 3/9/2004 12:35'!
defaultOrNil
	^ default! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 4/2/2003 15:25'!
register: aProviderClass
	(self registeredClasses includes: aProviderClass) ifFalse:
		[default _ nil.  "so it'll ask for a new default, since if you're registering a new app you probably want to use it"
		self registeredClasses add: aProviderClass].! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:01'!
registeredClasses
	^ registeredClasses ifNil: [registeredClasses _ OrderedCollection new]! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ar 9/27/2005 21:48'!
removeObsolete
	"AppRegistry removeObsoleteClasses"
	self registeredClasses copy do:[:cls| 
		(cls class isObsolete or:[cls isBehavior and:[cls isObsolete]]) 
			ifTrue:[self unregister: cls]].
	self subclasses do:[:cls| cls removeObsolete].! !

!AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:03'!
unregister: aProviderClass
	(default = aProviderClass) ifTrue: [default _ nil].
	self registeredClasses remove: aProviderClass ifAbsent: [].! !
ObjectSocket subclass: #ArbitraryObjectSocket
	instanceVariableNames: 'encodingOfLastEncodedObject lastEncodedObject'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Network-ObjectSocket'!
!ArbitraryObjectSocket commentStamp: '<historical>' prior: 0!
A network connection that passes objects instead of bytes.  The objects are encoded with SmartRefStreams.

!


!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 2/10/2005 20:40'!
inBufSize

	inBuf ifNil: [^0].
	^inBufLastIndex - inBufIndex + 1! !

!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: 'sd 11/20/2005 21:25'!
processInput
	"recieve some data"
	| inObjectData |

	[ socket dataAvailable ] whileTrue: [
		"read as much data as possible"
		self addToInBuf: socket receiveAvailableData.


		"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! !
TestCase subclass: #ArbitraryObjectSocketTestCase
	instanceVariableNames: 'socket1 socket2 end1 end2'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Nebraska-Network-ObjectSocket'!

!ArbitraryObjectSocketTestCase methodsFor: 'setup' stamp: 'sd 11/20/2005 21:25'!
setUp
	"it would be nice to have an in-image loopback socket, so that the tests do not need the underlying platform's sockets to behave nicely"
	socket1 := Socket newTCP.
	socket2 := Socket newTCP.
	
	socket1 listenOn: 9999.
	socket2 connectTo: (NetNameResolver localHostAddress) port: 9999.

	socket1 waitForConnectionFor: 60.	
	socket2 waitForConnectionFor: 60.
	
	end1 := ArbitraryObjectSocket on: socket1.
	end2 := ArbitraryObjectSocket on: socket2.
	! !


!ArbitraryObjectSocketTestCase methodsFor: 'testing' stamp: 'ls 2/10/2005 21:26'!
testBasics
	end1 nextPut: 'hello'.
	end1 nextPut: 42.
	end1 nextPut: 3@5.
	end1 processIO.  "hopefully one call is enough...."
	
	end2 processIO.  "hopefully one call is enough...."
	self should: [ end2 next = 'hello' ].
	self should: [ end2 next = 42 ].
	self should: [ end2 next = (3@5) ].
	! !
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"! !
Object subclass: #Archive
	instanceVariableNames: 'members'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Archives'!
!Archive commentStamp: '<historical>' prior: 0!
This is the abstract superclass for file archives. Archives can be read from or written to files, and contain members that represent files and directories.!


!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'!
addDirectory: aFileName
	^self addDirectory: aFileName as: aFileName
! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:57'!
addDirectory: aFileName as: anotherFileName
	| newMember |
	newMember := self memberClass newFromDirectory: aFileName.
	self addMember: newMember.
	newMember localFileName: anotherFileName.
	^newMember! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:29'!
addFile: aFileName
	^self addFile: aFileName as: aFileName! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'!
addFile: aFileName as: anotherFileName
	| newMember |
	newMember := self memberClass newFromFile: aFileName.
	self addMember: newMember.
	newMember localFileName: anotherFileName.
	^newMember! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'!
addMember: aMember
	^members addLast: aMember! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'!
addString: aString as: aFileName
	| newMember |
	newMember := self memberClass newFromString: aString named: aFileName.
	self addMember: newMember.
	newMember localFileName: aFileName.
	^newMember! !

!Archive methodsFor: 'archive operations' stamp: 'tak 2/2/2005 13:22'!
addTree: aFileNameOrDirectory match: aBlock 
	| nameSize |
	nameSize := aFileNameOrDirectory isString
				ifTrue: [aFileNameOrDirectory size]
				ifFalse: [aFileNameOrDirectory pathName size].
	^ self
		addTree: aFileNameOrDirectory
		removingFirstCharacters: nameSize + 1
		match: aBlock! !

!Archive methodsFor: 'archive operations' stamp: 'tak 2/2/2005 13:00'!
addTree: aFileNameOrDirectory removingFirstCharacters: n 
	^ self
		addTree: aFileNameOrDirectory
		removingFirstCharacters: n
		match: [:e | true]! !

!Archive methodsFor: 'archive operations' stamp: 'tak 2/15/2005 11:27'!
addTree: aFileNameOrDirectory removingFirstCharacters: n match: aBlock
	| dir newMember fullPath relativePath |
	dir := (aFileNameOrDirectory isString)
		ifTrue: [ FileDirectory on: aFileNameOrDirectory ]
		ifFalse: [ aFileNameOrDirectory ].
	fullPath := dir pathName, dir slash.
	relativePath := fullPath copyFrom: n + 1 to: fullPath size.
	(dir entries select: [ :entry | aBlock value: entry])
		do: [ :ea | | fullName |
		fullName := fullPath, ea name.
		newMember := ea isDirectory
				ifTrue: [ self memberClass newFromDirectory: fullName ]
				ifFalse: [ self memberClass newFromFile: fullName ].
		newMember localFileName: relativePath, ea name.
		self addMember: newMember.
		ea isDirectory ifTrue: [ self addTree: fullName removingFirstCharacters: n match: aBlock].
	].
! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:12'!
canWriteToFileNamed: aFileName
	"Catch attempts to overwrite existing zip file"
	^(members anySatisfy: [ :ea | ea usesFileNamed: aFileName ]) not.
! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'!
contentsOf: aMemberOrName
	| member |
	member := self member: aMemberOrName.
	member ifNil: [ ^nil ].
	^member contents! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48'!
extractMember: aMemberOrName
	| member |
	member := self member: aMemberOrName.
	member ifNil: [ ^nil ].
	member extractToFileNamed: member localFileName inDirectory: FileDirectory default.! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'!
extractMember: aMemberOrName toFileNamed: aFileName
	| member |
	member := self member: aMemberOrName.
	member ifNil: [ ^nil ].
	member extractToFileNamed: aFileName! !

!Archive methodsFor: 'archive operations' stamp: 'nk 11/11/2002 14:09'!
extractMemberWithoutPath: aMemberOrName
	self extractMemberWithoutPath: aMemberOrName inDirectory: FileDirectory default.! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48'!
extractMemberWithoutPath: aMemberOrName inDirectory: dir
	| member |
	member := self member: aMemberOrName.
	member ifNil: [ ^nil ].
	member extractToFileNamed: (FileDirectory localNameFor: member localFileName) inDirectory: dir! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'!
memberNamed: aString
	"Return the first member whose zip name or local file name matches aString, or nil"
	^members detect: [ :ea | ea fileName = aString or: [ ea localFileName = aString ]] ifNone: [ ]! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:00'!
memberNames
	^members collect: [ :ea | ea fileName ]! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:58'!
members
	^members! !

!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'!
membersMatching: aString
	^members select: [ :ea | (aString match: ea fileName) or: [ aString match: ea localFileName ] ]! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:59'!
numberOfMembers
	^members size! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'!
removeMember: aMemberOrName
	| member |
	member := self member: aMemberOrName.
	member ifNotNil: [ members remove: member ].
	^member! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'!
replaceMember: aMemberOrName with: newMember
	| member |
	member := self member: aMemberOrName.
	member ifNotNil: [ members replaceAll: member with: newMember ].
	^member! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 17:24'!
setContentsOf: aMemberOrName to: aString
	| newMember oldMember |
	oldMember := self member: aMemberOrName.
	newMember := (self memberClass newFromString: aString named: oldMember fileName)
		copyFrom: oldMember.
	self replaceMember: oldMember with: newMember.! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 20:58'!
writeTo: aStream
	self subclassResponsibility! !

!Archive methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:15'!
writeToFileNamed: aFileName
	| stream |
	"Catch attempts to overwrite existing zip file"
	(self canWriteToFileNamed: aFileName)
		ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ].
	stream := StandardFileStream forceNewFileNamed: aFileName.
	self writeTo: stream.
	stream close.! !


!Archive methodsFor: 'initialization' stamp: 'nk 2/21/2001 17:58'!
initialize
	members := OrderedCollection new.! !


!Archive methodsFor: 'private' stamp: 'nk 2/22/2001 07:56'!
member: aMemberOrName
	^(members includes: aMemberOrName)
		ifTrue: [ aMemberOrName ]
		ifFalse: [ self memberNamed: aMemberOrName ].! !

!Archive methodsFor: 'private' stamp: 'nk 2/21/2001 18:14'!
memberClass
	self subclassResponsibility! !
Object subclass: #ArchiveMember
	instanceVariableNames: 'fileName isCorrupt'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compression-Archives'!
!ArchiveMember commentStamp: '<historical>' prior: 0!
This is the abstract superclass for archive members, which are files or directories stored in archives.!


!ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'!
fileName
	^fileName! !

!ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'!
fileName: aName
	fileName := aName! !

!ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:16'!
isCorrupt
	^isCorrupt ifNil: [ isCorrupt := false ]! !

!ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:06'!
isCorrupt: aBoolean
	"Mark this member as being corrupt."
	isCorrupt := aBoolean! !

!ArchiveMember methodsFor: 'accessing' stamp: 'nk 12/20/2002 15:02'!
localFileName: aString
	"Set my internal filename.
	Returns the (possibly new) filename.
	aString will be translated from local FS format into Unix format."

	^fileName := aString copyReplaceAll: FileDirectory slash with: '/'.! !


!ArchiveMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'!
close
! !

!ArchiveMember methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:05'!
initialize
	fileName := ''.
	isCorrupt := false.! !


!ArchiveMember methodsFor: 'printing' stamp: 'nk 12/20/2002 15:11'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(;
		nextPutAll: self fileName;
		nextPut: $)! !


!ArchiveMember methodsFor: 'testing' stamp: 'nk 2/21/2001 19:43'!
usesFileNamed: aFileName
	"Do I require aFileName? That is, do I care if it's clobbered?"
	^false! !

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

ArchiveMember class
	instanceVariableNames: ''!

!ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:33'!
newDirectoryNamed: aString
	self subclassResponsibility! !

!ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'!
newFromFile: aFileName
	self subclassResponsibility! !

!ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'!
newFromString: aString
	self subclassResponsibility! !
SystemWindow subclass: #ArchiveViewer
	instanceVariableNames: 'archive fileName memberIndex viewAllContents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-ArchiveViewer'!
!ArchiveViewer commentStamp: '<historical>' prior: 0!
This is a viewer window that allows editing and viewing of Zip archives.!


!ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 11:03'!
archive
	^archive! !

!ArchiveViewer methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:36'!
directory
	"For compatibility with file list."
	^self error: 'should use readOnlyStream instead!!'! !

!ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 11:03'!
fileName
	^fileName! !

!ArchiveViewer methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
fullName
	"For compatibility with FileList services.
	If this is called, it means that a service that requires a real filename has been requested.
	So extract the selected member to a temporary file and return that name."

	| fullName dir |
	self canExtractMember ifFalse: [ ^nil ].
	dir := FileDirectory default directoryNamed: '.archiveViewerTemp'.
	fullName := dir fullNameFor: self selectedMember localFileName.
	self selectedMember extractInDirectory: dir.
	^fullName! !

!ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 14:56'!
members
	^archive ifNil: [ #() asOrderedCollection ]
		ifNotNil: [ archive members asOrderedCollection ]! !

!ArchiveViewer methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:39'!
readOnlyStream
	"Answer a read-only stream on the selected member.
	For the various stream-reading services."

	^self selectedMember ifNotNilDo: [ :mem | mem contentStream ascii ]! !

!ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 11:17'!
selectedMember
	^memberIndex
		ifNil: [ nil ]
		ifNotNil: [ self members at: memberIndex ifAbsent: [ ] ]! !


!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:54'!
canCreateNewArchive
	^true! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'dgd 2/21/2003 22:36'!
canExtractAll
	^self members notEmpty! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 11:12'!
canOpenNewArchive
	^true! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:55'!
canSaveArchive
	^archive notNil! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'sd 11/20/2005 21:26'!
commentArchive
	| newName |
	archive ifNil: [ ^self ].
	newName := FillInTheBlankMorph
			request: 'New comment for archive:'
			initialAnswer: archive zipFileComment
			centerAt: Sensor cursorPoint
			inWorld: self world
			onCancelReturn: archive zipFileComment
			acceptOnCR: true.
	archive zipFileComment: newName.! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'sd 11/20/2005 21:26'!
createNewArchive
	self setLabel: '(new archive)'.
	archive := ZipArchive new.
	self memberIndex: 0.
	self changed: #memberList.! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'sd 11/20/2005 21:26'!
extractAll
	| directory |

	self canExtractAll ifFalse: [^ self].
	directory := FileList2 modalFolderSelector ifNil: [^ self].
	archive extractAllTo: directory.! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'sd 11/20/2005 21:26'!
extractAllPossibleInDirectory: directory
	"Answer true if I can extract all the files in the given directory safely.
	Inform the user as to problems."
	| conflicts |
	self canExtractAll ifFalse: [ ^false ].
	conflicts := Set new.
	self members do: [ :ea | | fullName |
		fullName := directory fullNameFor: ea localFileName.
		(ea usesFileNamed: fullName) ifTrue: [ conflicts add: fullName ].
	].
	conflicts notEmpty ifTrue: [ | str |
		str := WriteStream on: (String new: 200).
		str nextPutAll: 'The following file(s) are needed by archive members and cannot be overwritten:';
			cr.
		conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ].
		self inform: str contents.
		^false.
	].
	conflicts := Set new.
	self members do: [ :ea | | fullName  |
		fullName := directory relativeNameFor: ea localFileName.
		(directory fileExists: fullName)
			ifTrue: [ conflicts add: fullName ].
	].
	conflicts notEmpty ifTrue: [ | str |
		str := WriteStream on: (String new: 200).
		str nextPutAll: 'The following file(s) will be overwritten:'; cr.
		conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ].
		str cr; nextPutAll: 'Is this OK?'.
		^self confirm: str contents.
	].
	^true.
! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:14'!
extractDirectoriesIntoDirectory: directory 
	(self members select: [:ea | ea isDirectory]) 
		do: [:ea | ea extractInDirectory: directory]! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:13'!
extractFilesIntoDirectory: directory 
	(self members reject: [:ea | ea isDirectory]) 
		do: [:ea | ea extractInDirectory: directory]! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'sd 11/20/2005 21:26'!
openNewArchive
	| menu result |
	menu := StandardFileMenu oldFileMenu: (FileDirectory default) withPattern: '*.zip'.
	result := menu startUpWithCaption: 'Select Zip archive to open...'.
	result ifNil: [ ^self ].
	self fileName: (result directory fullNameFor: result name).
! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'sd 11/20/2005 21:26'!
saveArchive
	| result name |
	self canSaveArchive ifFalse: [ ^self ].
	result := StandardFileMenu newFile.
	result ifNil: [ ^self ].
	name := result directory fullNameFor: result name.
	(archive canWriteToFileNamed: name)
		ifFalse: [ self inform: name, ' is used by one or more members
in your archive, and cannot be overwritten.
Try writing to another file name'.
			^self ].
	[ archive writeToFileNamed: name ] on: Error do: [ :ex | self inform: ex description. ].
	self setLabel: name asString.
	self changed: #memberList	"in case CRC's and compressed sizes got set"! !

!ArchiveViewer methodsFor: 'archive operations' stamp: 'sd 11/20/2005 21:26'!
writePrependingFile
	| result name prependedName |
	self canSaveArchive ifFalse: [ ^self ].
	result := (StandardFileMenu newFileMenu: FileDirectory default)
		startUpWithCaption: 'Destination Zip File Name:'.
	result ifNil: [ ^self ].
	name := result directory fullNameFor: result name.
	(archive canWriteToFileNamed: name)
		ifFalse: [ self inform: name, ' is used by one or more members
in your archive, and cannot be overwritten.
Try writing to another file name'.
			^self ].
	result := (StandardFileMenu oldFileMenu: FileDirectory default)
		startUpWithCaption: 'Prepended File:'.
	result ifNil: [ ^self ].
	prependedName := result directory fullNameFor: result name.
	[ archive writeToFileNamed: name prependingFileNamed: prependedName ]
		on: Error
		do: [ :ex | self inform: ex description. ].
	self changed: #memberList	"in case CRC's and compressed sizes got set"! !


!ArchiveViewer methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
archive: aZipArchive
	archive := aZipArchive.
	self model: aZipArchive.
	self setLabel: 'New Zip Archive'.
	self memberIndex: 0.
	self changed: #memberList! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
briefContents
	"Trim to 5000 characters. If the member is longer, then point out that it is trimmed.
	Also warn if the member has a corrupt CRC-32."

	| stream subContents errorMessage |
	self selectedMember ifNil: [^ ''].
	errorMessage := ''.
	stream := WriteStream on: (String new: (self selectedMember uncompressedSize min: 5500)).

	[ self selectedMember uncompressedSize > 5000
		ifTrue: [ |  lastLineEndingIndex tempIndex |
			subContents := self selectedMember contentsFrom: 1 to: 5000.
			lastLineEndingIndex := subContents lastIndexOf: Character cr.
			tempIndex := subContents lastIndexOf: Character lf.
			tempIndex > lastLineEndingIndex ifTrue: [lastLineEndingIndex := tempIndex].
			lastLineEndingIndex = 0
				ifFalse: [subContents := subContents copyFrom: 1 to: lastLineEndingIndex]]
		ifFalse: [ subContents := self selectedMember contents ]]
			on: CRCError do: [ :ex |
				errorMessage := String streamContents: [ :s |
					s nextPutAll: '[ ';
						nextPutAll: (ex messageText copyUpToLast: $( );
						nextPutAll: ' ]' ].
				ex proceed ].

		(errorMessage isEmpty not or: [ self selectedMember isCorrupt ]) ifTrue: [
			stream nextPutAll: '********** WARNING!! Member is corrupt!! ';
					nextPutAll: errorMessage;
					nextPutAll: ' **********'; cr ].

	self selectedMember uncompressedSize > 5000
		ifTrue: [
			stream nextPutAll: 'File ';
				print: self selectedMember fileName;
				nextPutAll: ' is ';
				print: self selectedMember uncompressedSize;
				nextPutAll: ' bytes long.'; cr;
				nextPutAll: 'Click the ''View All Contents'' button above to see the entire file.'; cr; cr;
				nextPutAll: 'Here are the first ';
				print: subContents size;
				nextPutAll: ' characters...'; cr;
				next: 40 put: $-; cr;
				nextPutAll: subContents;
				next: 40 put: $-; cr;
				nextPutAll: '... end of the first ';
				print: subContents size;
				nextPutAll: ' characters.' ]
		ifFalse: [ stream nextPutAll: self selectedMember contents ].
		
		^stream contents
! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:58'!
buttonColor
	^self defaultBackgroundColor darker! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:59'!
buttonOffColor
	^self defaultBackgroundColor darker! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:59'!
buttonOnColor
	^self defaultBackgroundColor! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
contents
	| contents errorMessage |
	self selectedMember ifNil: [^ ''].
	viewAllContents ifFalse: [^ self briefContents].

 	[ contents := self selectedMember contents ]
		on: CRCError
		do: [ :ex | errorMessage := String streamContents: [ :stream |
			stream nextPutAll: '********** WARNING!! Member is corrupt!! [ ';
			nextPutAll: (ex messageText copyUpToLast: $( );
			nextPutAll: '] **********'; cr ].
			ex proceed ].

	^self selectedMember isCorrupt
		ifFalse: [ contents ]
		ifTrue: [ errorMessage, contents ]! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/25/2001 00:04'!
contents: aText
	self shouldNotImplement.! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
createButtonBar
	| bar button narrowFont registeredFonts |
	registeredFonts := OrderedCollection new.
	TextStyle knownTextStylesWithoutDefault do:
		[:st | (TextStyle named: st) fonts do: [:f | registeredFonts addLast: f]].		
	narrowFont := registeredFonts detectMin:
			[:ea | ea widthOfString: 'Contents' from: 1 to: 8].
	bar := AlignmentMorph newRow.
	bar
		color: self defaultBackgroundColor;
		rubberBandCells: false;
		vResizing: #shrinkWrap;
		cellInset: 6 @ 0.
	#(#('New\Archive' #canCreateNewArchive #createNewArchive 'Create a new, empty archive and discard this one') #('Load\Archive' #canOpenNewArchive #openNewArchive 'Open another archive and discard this one') #('Save\Archive As' #canSaveArchive #saveArchive 'Save this archive under a new name') #('Extract\All' #canExtractAll #extractAll 'Extract all this archive''s members into a directory') #('Add\File' #canAddMember #addMember 'Add a file to this archive') #('Add from\Clipboard' #canAddMember #addMemberFromClipboard 'Add the contents of the clipboard as a new file') #('Add\Directory' #canAddMember #addDirectory 'Add the entire contents of a directory, with all of its subdirectories') #('Extract\Member As' #canExtractMember #extractMember 'Extract the selected member to a file') #('Delete\Member' #canDeleteMember #deleteMember 'Remove the selected member from this archive') #('Rename\Member' #canRenameMember #renameMember 'Rename the selected member') #('View All\Contents' #canViewAllContents #changeViewAllContents 'Toggle the view of all the selected member''s contents')) 
		do: 
			[:arr | 
			| buttonLabel |
			buttonLabel := (TextMorph new)
						string: arr first withCRs
							fontName: narrowFont familyName
							size: narrowFont pointSize
							wrap: false;
						hResizing: #shrinkWrap;
						lock;
						yourself.
			(button := PluggableButtonMorph 
						on: self
						getState: arr second
						action: arr third)
				vResizing: #shrinkWrap;
				hResizing: #spaceFill;
				onColor: self buttonOnColor offColor: self buttonOffColor;
				label: buttonLabel;
				setBalloonText: arr fourth.
			bar addMorphBack: button.
			buttonLabel composeToBounds].
	^bar! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
createListHeadingUsingFont: font
	| sm |
	sm := StringMorph contents: '  uncomp     comp   CRC-32       date     time  file name'.
	font ifNotNil: [ sm font: font ].
	^(AlignmentMorph newColumn)
		color: self defaultBackgroundColor;
		addMorph: sm;
		yourself.! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
createWindow
	| list heading font text buttonBar |

	font := (TextStyle named: #DefaultFixedTextStyle)
		ifNotNilDo: [ :ts | ts fontArray first].

	buttonBar := self createButtonBar.
	self addMorph: buttonBar
		fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0@0.0) offsets: (0@0 corner: 0@44)).

	self minimumExtent: (buttonBar fullBounds width + 20) @ 230.
	self extent: self minimumExtent.

	heading := self createListHeadingUsingFont: font.
	self addMorph: heading
		fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0@0.0) offsets: (0@44 corner: 0@60)).

	(list := PluggableListMorph new)
		on: self list: #memberList
		selected: #memberIndex changeSelected: #memberIndex:
		menu: #memberMenu:shifted: keystroke: nil.
	list color: self defaultBackgroundColor.

	font ifNotNil: [list font: font].
	self addMorph: list
		fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0@0.8) offsets: (0@60 corner: 0@0)).

	text := PluggableTextMorph on: self 
			text: #contents accept: nil
			readSelection: nil menu: nil.
	self addMorph: text
		frame: (0@0.8 corner: 1.0@1.0).
	text lock.

	self setLabel: 'Ned''s Zip Viewer'! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
fileName: aString
	archive := ZipArchive new readFrom: aString.
	self setLabel: aString.
	self memberIndex:  0.
	self changed: #memberList! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
initialize
	super initialize.
	memberIndex := 0.
	viewAllContents := false.
! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'!
stream: aStream
	archive := ZipArchive new readFrom: aStream.
	self setLabel: aStream fullName.
	self memberIndex:  0.
	self changed: #memberList! !

!ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:15'!
windowIsClosing
	archive ifNotNil: [ archive close ].! !


!ArchiveViewer methodsFor: 'member list' stamp: 'sd 11/20/2005 21:26'!
displayLineFor: aMember
	| stream dateTime |
	stream := WriteStream on: (String new: 60).
	dateTime := Time dateAndTimeFromSeconds: aMember lastModTime. 
	stream
		nextPutAll: (aMember uncompressedSize printString padded: #left to: 8 with: $  );
		space;
		nextPutAll: (aMember compressedSize printString padded: #left to: 8 with: $  );
		space; space;
		nextPutAll: (aMember crc32String );
		space; space.
	dateTime first printOn: stream format: #(3 2 1 $- 2 1 2).
	stream space.
	dateTime second print24: true showSeconds: false on: stream.
	stream space; space;
		nextPutAll: (aMember fileName ).
	^stream contents! !

!ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/23/2001 22:48'!
highlightMemberList: list with: morphList
	(morphList at: self memberIndex) color: Color red! !

!ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 09:40'!
memberIndex
	^memberIndex! !

!ArchiveViewer methodsFor: 'member list' stamp: 'sd 11/20/2005 21:26'!
memberIndex: n
	memberIndex := n.
	viewAllContents := false.
	self changed: #memberIndex.
	self changed: #contents.! !

!ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 11:51'!
memberList
	^ self members collect: [ :ea | self displayLineFor: ea ]! !

!ArchiveViewer methodsFor: 'member list' stamp: 'sd 11/20/2005 21:26'!
memberMenu: menu shifted: shifted
	| services |

	menu
		add: 'Comment archive' target: self selector: #commentArchive;
		balloonTextForLastItem: 'Add a comment for the entire archive'.

	self selectedMember ifNotNilDo: [ :member |
		menu
			addLine;
			add: 'Inspect member' target: self selector: #inspectMember;
			balloonTextForLastItem: 'Inspect the selected member';
			add: 'Comment member' target: self selector: #commentMember;
			balloonTextForLastItem: 'Add a comment for the selected member';
			addLine.
		services := FileList itemsForFile: member fileName.
		menu addServices2: services for: self extraLines: #().
	].


	^menu! !


!ArchiveViewer methodsFor: 'member operations' stamp: 'sd 11/20/2005 21:26'!
addDirectory
	| directory |
	self canAddMember ifFalse: [ ^self ].
	directory := FileList2 modalFolderSelector.
	directory
		ifNil: [^ self].
	archive addTree: directory removingFirstCharacters: directory pathName size + 1.
	self memberIndex: 0.
	self changed: #memberList.! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'sd 11/20/2005 21:26'!
addMember
	| result relative |
	self canAddMember ifFalse: [ ^self ].
	result := StandardFileMenu oldFile.
	result ifNil: [ ^self ].
	relative := result directory fullNameFor: result name.
	(relative beginsWith: FileDirectory default pathName)
		ifTrue: [ relative := relative copyFrom: FileDirectory default pathName size + 2 to: relative size ].
	(archive addFile: relative)
		desiredCompressionMethod: ZipArchive compressionDeflated.
	self memberIndex: self members size.
	self changed: #memberList.! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'sd 11/20/2005 21:26'!
addMemberFromClipboard
	| string newName |
	self canAddMember ifFalse: [ ^self ].
	string := Clipboard clipboardText asString.
	newName := FillInTheBlankMorph
		request: 'New name for member:'
		initialAnswer: 'clipboardText'.
	newName notEmpty ifTrue: [
		(archive addString: string as: newName) desiredCompressionMethod: ZipArchive compressionDeflated.
		self memberIndex: self members size.
		self changed: #memberList.
	]
! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 14:50'!
canAddMember
	^archive notNil! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 11:02'!
canDeleteMember
	^memberIndex > 0! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 11:02'!
canExtractMember
	^memberIndex > 0! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 11:02'!
canRenameMember
	^memberIndex > 0! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:50'!
canViewAllContents
	^memberIndex > 0 and: [ viewAllContents not ]! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'sd 11/20/2005 21:26'!
changeViewAllContents

	(viewAllContents not and: [ self selectedMember notNil and: [ self selectedMember uncompressedSize > 50000 ]])
		ifTrue: [ (self confirm: 'This member''s size is ',
			(self selectedMember uncompressedSize asString),
			'; do you really want to see all that data?')
				ifFalse: [ ^self ]
		].

	viewAllContents := viewAllContents not.
	self changed: #contents! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'sd 11/20/2005 21:26'!
commentMember
	| newName |
	newName := FillInTheBlankMorph
			request: 'New comment for member:'
			initialAnswer: self selectedMember fileComment
			centerAt: Sensor cursorPoint
			inWorld: self world
			onCancelReturn: self selectedMember fileComment
			acceptOnCR: true.
	self selectedMember fileComment: newName.! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:29'!
deleteMember
	self canDeleteMember ifFalse: [ ^self ].
	archive removeMember: self selectedMember.
	self memberIndex:  0.
	self changed: #memberList.
! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'sd 11/20/2005 21:26'!
extractMember
	"Extract the member after prompting for a filename.
	Answer the filename, or nil if error."

	| result name |
	self canExtractMember ifFalse: [ ^nil ].
	result := StandardFileMenu newFile.
	result ifNil: [ ^nil ].
	name := (result directory fullNameFor: result name).
	(archive canWriteToFileNamed: name)
		ifFalse: [ self inform: name, ' is used by one or more members
in your archive, and cannot be overwritten.
Try extracting to another file name'.
			^nil ].
	self selectedMember extractToFileNamed: name.
	^name! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 13:01'!
inspectMember
	self selectedMember inspect! !

!ArchiveViewer methodsFor: 'member operations' stamp: 'sd 11/20/2005 21:26'!
renameMember
	| newName |
	self canRenameMember ifFalse: [ ^self ].
	newName := FillInTheBlankMorph
		request: 'New name for member:'
		initialAnswer: self selectedMember fileName.
	newName notEmpty ifTrue: [
		self selectedMember fileName: newName.
		self changed: #memberList
	]! !


!ArchiveViewer methodsFor: 'menu' stamp: 'sd 11/20/2005 21:26'!
buildWindowMenu
	| menu |
	menu := super buildWindowMenu.
	menu addLine.
	menu add: 'inspect archive' target: archive action: #inspect.
	menu add: 'write prepending file...' target: self action: #writePrependingFile.
	^menu.! !


!ArchiveViewer methodsFor: 'message handling' stamp: 'nk 2/24/2001 13:16'!
perform: selector orSendTo: otherTarget
	^ self perform: selector! !


!ArchiveViewer methodsFor: 'parts bin' stamp: 'dls 10/22/2001 07:40'!
initializeToStandAlone
	self initialize createWindow.! !

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

ArchiveViewer class
	instanceVariableNames: ''!

!ArchiveViewer class methodsFor: 'class initialization' stamp: 'sd 11/20/2005 21:27'!
deleteTemporaryDirectory
	"
	ArchiveViewer deleteTemporaryDirectory
	"

	| dir |
	(dir := self temporaryDirectory) exists ifTrue: [ dir recursiveDelete ].! !

!ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 4/29/2004 10:56'!
initialize
	"ArchiveViewer initialize"

	FileList registerFileReader: self.
	Smalltalk addToShutDownList: self.! !

!ArchiveViewer class methodsFor: 'class initialization' stamp: 'sw 2/17/2002 02:35'!
serviceOpenInZipViewer
	"Answer a service for opening in a zip viewer"

	^ SimpleServiceEntry
		provider: self
		label: 'open in zip viewer'
		selector: #openOn: 
		description: 'open in zip viewer'
		buttonLabel: 'open zip'! !

!ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 4/29/2004 11:06'!
shutDown: quitting
	quitting ifTrue: [ self deleteTemporaryDirectory ].! !


!ArchiveViewer class methodsFor: 'file list services' stamp: 'nk 11/26/2002 12:46'!
extractAllFrom: aFileName
	(self new) fileName: aFileName; extractAll! !

!ArchiveViewer class methodsFor: 'file list services' stamp: 'nk 11/26/2002 12:48'!
serviceAddToNewZip
	"Answer a service for adding the file to a new zip"

	^ FileModifyingSimpleServiceEntry 
		provider: self
		label: 'add file to new zip'
		selector: #addFileToNewZip:
		description: 'add file to new zip'
		buttonLabel: 'to new zip'! !

!ArchiveViewer class methodsFor: 'file list services' stamp: 'nk 11/26/2002 12:15'!
serviceExtractAll
	"Answer a service for opening in a zip viewer"

	^ FileModifyingSimpleServiceEntry 
		provider: self
		label: 'extract all to...'
		selector: #extractAllFrom: 
		description: 'extract all files to a user-specified directory'
		buttonLabel: 'extract all'! !


!ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'sd 11/20/2005 21:27'!
fileReaderServicesForFile: fullName suffix: suffix 

	|  services |
	services := OrderedCollection new.
	services add: self serviceAddToNewZip.
	({'zip'.'sar'.'pr'. 'mcz'. '*'} includes: suffix)
		ifTrue: [services add: self serviceOpenInZipViewer.
				services add: self serviceExtractAll].
	^ services! !

!ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 21:18'!
services
	
	^ Array 
		with: self serviceAddToNewZip
		with: self serviceOpenInZipViewer
					
			! !

!ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'nk 4/29/2004 10:56'!
temporaryDirectory
	"Answer a directory to use for unpacking files for the file list services."
	^FileDirectory default directoryNamed: '.archiveViewerTemp'! !


!ArchiveViewer class methodsFor: 'initialize-release' stamp: 'nk 1/30/2002 10:13'!
unload

	FileList unregisterFileReader: self ! !


!ArchiveViewer class methodsFor: 'instance creation' stamp: 'nk 1/30/2002 10:18'!
addFileToNewZip: fullName

	"Add the currently selected file to a new zip"
	| zip |
	zip := (ZipArchive new) 
			addFile: fullName 
			as: (FileDirectory localNameFor: fullName); yourself.
	(self open) archive: zip
! !

!ArchiveViewer class methodsFor: 'instance creation' stamp: 'nk 2/23/2001 21:52'!
open
	^(self new) createWindow; openInWorld.! !

!ArchiveViewer class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:27'!
openOn: aFileName
	| newMe |
	newMe := self new.
	newMe createWindow; fileName: aFileName; openInWorld.
	^newMe! !


!ArchiveViewer class methodsFor: 'parts bin' stamp: 'nk 3/27/2002 11:41'!
descriptionForPartsBin

	^ self partName: 'Zip Tool'
		categories: #(Tools)
		documentation: 'A viewer and editor for Zip archive files'
! !
Error subclass: #ArithmeticError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
ArrayedCollection variableSubclass: #Array
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!Array commentStamp: '<historical>' prior: 0!
I present an ArrayedCollection whose elements are objects.!


!Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:02'!
atWrap: index 
	"Optimized to go through the primitive if possible"
	<primitive: 60>
	^ self at: index - 1 \\ self size + 1! !

!Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:03'!
atWrap: index put: anObject
	"Optimized to go through the primitive if possible"
	<primitive: 61>
	^ self at: index - 1 \\ self size + 1 put: anObject! !


!Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:09'!
+* aCollection
	"Premultiply aCollection by self.  aCollection should be an Array or Matrix.
	 The name of this method is APL's +.x squished into Smalltalk syntax."

	^aCollection preMultiplyByArray: self
! !

!Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:10'!
preMultiplyByArray: a
	"Answer a+*self where a is an Array.  Arrays are always understood as column vectors,
	 so an n element Array is an n*1 Array.  This multiplication is legal iff self size = 1."

	self size = 1 ifFalse: [self error: 'dimensions do not conform'].
	^a * self first! !

!Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:08'!
preMultiplyByMatrix: m
	"Answer m+*self where m is a Matrix."
	|s|

	m columnCount = self size ifFalse: [self error: 'dimensions do not conform'].
	^(1 to: m rowCount) collect: [:row |
		s _ 0.
		1 to: self size do: [:k | s _ (m at: row at: k) * (self at: k) + s].
		s]! !


!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: 'comparing' stamp: 'ajh 2/2/2002 15:03'!
literalEqual: other

	self class == other class ifFalse: [^ false].
	self size = other size ifFalse: [^ false].
	self with: other do: [:e1 :e2 |
		(e1 literalEqual: e2) ifFalse: [^ false]].
	^ true! !


!Array methodsFor: 'converting' stamp: 'sma 5/12/2000 17:32'!
asArray
	"Answer with the receiver itself."

	^ self! !

!Array methodsFor: 'converting' stamp: 'tpr 11/2/2004 11:31'!
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>
	otherArray class == Array ifFalse: [^ self error: 'arg must be array'].
	self size = otherArray size ifFalse: [^ self error: 'arrays must be same size'].
	(self anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers'].
	(otherArray anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers'].
	self with: otherArray do:[:a :b| a == b ifTrue:[^self error:'can''t become yourself']].

	"Must have failed because not enough space in forwarding table (see ObjectMemory-prepareForwardingTableForBecoming:with:twoWay:).  Do GC and try again only once"
	(Smalltalk bytesLeft: true) = Smalltalk primitiveGarbageCollect
		ifTrue: [^ self primitiveFailed].
	^ self elementsExchangeIdentityWith: otherArray! !

!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' stamp: 'brp 9/26/2003 08:09'!
elementsForwardIdentityTo: otherArray copyHash: copyHash
	"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: 249>
	self primitiveFailed! !

!Array methodsFor: 'converting' stamp: 'ar 4/10/2005 18:03'!
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 isString and:[each isSymbol not]) ifTrue: [
			it _ Compiler evaluate: each].
        each class == Array ifTrue: [it _ it evalStrings].
        it]! !


!Array methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'!
copyWithDependent: newElement
	self size = 0 ifTrue:[^DependentsArray with: newElement].
	^self copyWith: newElement! !


!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 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: 'printing' stamp: 'sd 7/31/2005 21:44'!
printOn: aStream
	self isLiteral ifTrue: [self printAsLiteralFormOn: aStream. ^ self].
	self isSelfEvaluating ifTrue: [self printAsSelfEvaluatingFormOn: aStream. ^ self].

	super printOn: 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: 'self evaluating' stamp: 'sd 7/31/2005 21:44'!
isSelfEvaluating
	^ (self allSatisfy: [:each | each isSelfEvaluating]) and: [self class == Array]! !

!Array methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'!
printAsLiteralFormOn: aStream
	aStream nextPut: $#.
	self printElementsOn: aStream
! !

!Array methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'!
printAsSelfEvaluatingFormOn: aStream

	aStream nextPut: ${.
	self do: [:el | aStream print: el] separatedBy: [ aStream nextPutAll: ' . '].
	aStream nextPut: $}! !


!Array methodsFor: 'testing' stamp: 'md 7/30/2005 21:19'!
isArray
	^true! !

!Array methodsFor: 'testing' stamp: 'sma 5/12/2000 14:11'!
isLiteral
	^ self allSatisfy: [:each | each isLiteral]! !


!Array methodsFor: 'private' stamp: 'md 1/20/2006 16:53'!
hasLiteralThorough: literal
	"Answer true if literal is identical to any literal in this array, even if imbedded in further array structures or closure methods"

	| lit |
	1 to: self size do: [:index |
		(lit _ self at: index) == literal ifTrue: [^ true].
		(lit hasLiteralThorough: literal) ifTrue: [^ true]].
	^ false! !

!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: 'md 3/1/2006 21:09'!
hasLiteralSuchThat: testBlock
	"Answer true if testBlock returns true for any literal in this array, even if imbedded in 	further Arrays or CompiledMethods.  This method is only intended for private use by 	CompiledMethod 	hasLiteralSuchThat:"
	| lit |
	1 to: self size do: [:index |
		(testBlock value: (lit _ self at: index)) ifTrue: [^ true].
		(lit hasLiteralSuchThat: testBlock) 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 class
	instanceVariableNames: ''!

!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! !


!Array class methodsFor: 'instance creation' stamp: 'md 7/19/2004 12:34'!
new: sizeRequested 
	"Answer an instance of this class with the number of indexable
	variables specified by the argument, sizeRequested.
	
	This is a shortcut (direct call of primitive, no #initialize, for performance"

	<primitive: 71>  "This method runs primitively if successful"
	^ self basicNew: sizeRequested  "Exceptional conditions will be handled in basicNew:"
! !
TestCase subclass: #ArrayLiteralTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-Tests'!

!ArrayLiteralTest methodsFor: 'initialize-release' stamp: 'avi 2/16/2004 21:09'!
tearDown
	self class removeSelector: #array! !


!ArrayLiteralTest methodsFor: 'tests' stamp: 'avi 2/16/2004 21:08'!
testReservedIdentifiers
	self class compile: 'array ^ #(nil true false)'.
	self assert: self array = {nil. true. false}.! !

!ArrayLiteralTest methodsFor: 'tests' stamp: 'avi 2/16/2004 21:09'!
testSymbols
	self class compile: 'array ^ #(#nil #true #false #''nil'' #''true'' #''false'')'.
	self assert: self array = {#nil. #true. #false. #nil. #true. #false}.! !
ClassTestCase subclass: #ArrayTest
	instanceVariableNames: 'example1 literalArray selfEvaluatingArray otherArray nonSEArray1 nonSEarray2 example2'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Arrayed'!
!ArrayTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Array. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- http://minnow.cc.gatech.edu/squeak/1547
	- the sunit class category!


!ArrayTest methodsFor: 'initialize-release' stamp: 'md 4/25/2006 14:38'!
setUp

	literalArray := #(1 true 3 #four).
	selfEvaluatingArray := { 1. true. (3/4). Color black. (2 to: 4) . 5 }.
	nonSEArray1 := { 1 . Set with: 1 }.
	nonSEarray2 := { Smalltalk associationAt: #Array }.
	example1 := #(1 2 3 4 5).
	example2 := {1. 2. 3/4. 4. 5}. ! !


!ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:12'!
testIsArray
	
	self assert: example1 isArray! !

!ArrayTest methodsFor: 'testing' stamp: 'apb 4/21/2006 08:59'!
testIsLiteral
	"We work with a copy of literalArray, to avoid corrupting the code."
	| l |
	l := literalArray copy.
	self assert: l isLiteral.
	l at: 1 put: self class.
	self deny: l isLiteral! !

!ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:18'!
testIsSelfEvaluating

	self assert: example1 isSelfEvaluating.
	example1 at: 1 put: Bag new.
	self deny: example1 isSelfEvaluating.
	example1 at: 1 put: 1.! !

!ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:50'!
testLiteralEqual
	self
		deny: (example1 literalEqual: example1 asIntegerArray)! !

!ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:50'!
testPremultiply
	self assert: example1 +* #(2 ) = #(2 4 6 8 10 ) ! !

!ArrayTest methodsFor: 'testing' stamp: 'apb 4/21/2006 09:25'!
testPrinting
	self assert: literalArray printString = '#(1 true 3 #four)'.
	self assert: (literalArray = (Compiler evaluate: literalArray printString)).
	self assert: selfEvaluatingArray printString =  '{1 . true . (3/4) . Color black . (2 to: 4) . 5}'.
	self assert: (selfEvaluatingArray = (Compiler evaluate: selfEvaluatingArray printString)).
	self assert: nonSEArray1 printString =  'an Array(1 a Set(1))'.
	self assert: nonSEarray2 printString =  'an Array(#Array)'
! !
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>=0) 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: 'objects from disk' stamp: 'nk 3/17/2004 15:22'!
byteSize
	^self basicSize * self bytesPerBasicElement
! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:28'!
bytesPerBasicElement
	"Answer the number of bytes that each of my basic elements requires.
	In other words:
		self basicSize * self bytesPerBasicElement
	should equal the space required on disk by my variable sized representation."
	^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ]! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 18:51'!
bytesPerElement
	^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ].
! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 7/30/2004 17:50'!
restoreEndianness
	"This word object was just read in from a stream.  It was stored in Big Endian (Mac) format.  Reverse the byte order if the current machine is Little Endian.
	We only intend this for non-pointer arrays.  Do nothing if I contain pointers."

	self class isPointers | self class isWords not ifTrue: [^self].
	SmalltalkImage current  isLittleEndian 
		ifTrue: 
			[Bitmap 
				swapBytesIn: self
				from: 1
				to: self basicSize]! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 17:36'!
swapHalves
		"A normal switch in endianness (byte order in words) reverses the order of 4 bytes.  That is not correct for SoundBuffers, which use 2-bytes units.  If a normal switch has be done, this method corrects it further by swapping the two halves of the long word.
	This method is only used for 16-bit quanities in SoundBuffer, ShortIntegerArray, etc."

	| hack blt |
	"The implementation is a hack, but fast for large ranges"
	hack _ Form new hackBits: self.
	blt _ (BitBlt toForm: hack) sourceForm: hack.
	blt combinationRule: Form reverse.  "XOR"
	blt sourceY: 0; destY: 0; height: self size; width: 2.
	blt sourceX: 0; destX: 2; copyBits.  "Exchange bytes 0&1 with 2&3"
	blt sourceX: 2; destX: 0; copyBits.
	blt sourceX: 0; destX: 2; copyBits.! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'ar 5/17/2001 19:50'!
writeOn: aStream 
	"Store the array of bits onto the argument, aStream.  (leading byte ~= 16r80) identifies this as raw bits (uncompressed).  Always store in Big Endian (Mac) byte order.  Do the writing at BitBlt speeds. We only intend this for non-pointer arrays.  Do nothing if I contain pointers."
	self class isPointers | self class isWords not ifTrue: [^ super writeOn: aStream].
				"super may cause an error, but will not be called."
	aStream nextInt32Put: self basicSize.
	aStream nextWordsPutAll: self.! !

!ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 18:07'!
writeOnGZIPByteStream: aStream 
	"We only intend this for non-pointer arrays.  Do nothing if I contain pointers."

	self class isPointers | self class isWords not ifTrue: [^ super writeOnGZIPByteStream: aStream].
		"super may cause an error, but will not be called."
	
	aStream nextPutAllWordArray: 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: '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 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 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' stamp: 'ar 5/17/2001 19:50'!
newFromStream: s
	"Only meant for my subclasses that are raw bits and word-like.  For quick unpack form the disk."
	| len |

	self isPointers | self isWords not ifTrue: [^ super newFromStream: s].
		"super may cause an error, but will not be called."

	s next = 16r80 ifTrue:
		["A compressed format.  Could copy what BitMap does, or use a 
		special sound compression format.  Callers normally compress their own way."
		^ self error: 'not implemented'].
	s skip: -1.
	len _ s nextInt32.
	^ s nextWordsInto: (self basicNew: len)! !

!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: 'Exceptions-Extensions'!
!AssertionFailure commentStamp: 'gh 5/2/2002 20:29' prior: 0!
AsssertionFailure is the exception signaled from Object>>assert: when the assertion block evaluates to false.!

ParseNode subclass: #AssignmentNode
	instanceVariableNames: 'variable value'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!AssignmentNode commentStamp: '<historical>' prior: 0!
AssignmentNode comment: 'I represent a (var_expr) construct.'!


!AssignmentNode methodsFor: 'code generation' stamp: 'di 9/5/2001 18:46'!
emitForEffect: stack on: aStream

	variable emitLoad: stack on: aStream.
	value emitForValue: stack on: aStream.
	variable emitStorePop: stack on: aStream.
	pc _ aStream position! !

!AssignmentNode methodsFor: 'code generation' stamp: 'di 9/5/2001 21:26'!
emitForValue: stack on: aStream

	variable emitLoad: stack on: aStream.
	value emitForValue: stack on: aStream.
	variable emitStore: stack on: aStream.
	pc _ aStream position! !

!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: 'equation translation'!
variable
	^variable! !


!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: 'initialize-release' stamp: 'hmm 7/15/2001 21:17'!
variable: aVariable value: expression from: encoder sourceRange: range

	encoder noteSourceRange: range forNode: self.
	^self
		variable: aVariable
		value: expression
		from: encoder! !


!AssignmentNode methodsFor: 'printing' stamp: 'md 3/8/2006 09:33'!
printOn: aStream indent: level 
	variable printOn: aStream indent: level.
	aStream nextPutAll: ' := '.
	value printOn: aStream indent: level + 2.! !

!AssignmentNode methodsFor: 'printing' stamp: 'md 8/14/2005 17:30'!
printOn: aStream indent: level precedence: p

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


!AssignmentNode methodsFor: '*eToys-tiles' stamp: 'RAA 2/26/2001 16:17'!
asMorphicSyntaxIn: parent

	^parent assignmentNode: self variable: variable value: value! !

!AssignmentNode methodsFor: '*eToys-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: 'EToys-Scripting Tiles'!

!AssignmentTileMorph methodsFor: 'accessing' stamp: 'tak 12/5/2004 14:04'!
options
	^ {#(#: #Incr: #Decr: #Mult: ). {nil. nil. nil. nil}}! !

!AssignmentTileMorph methodsFor: 'accessing' stamp: 'tak 12/5/2004 14:09'!
value
	^ assignmentSuffix! !

!AssignmentTileMorph methodsFor: 'accessing' stamp: 'tak 12/5/2004 14:06'!
value: anObject 
	self setAssignmentSuffix: anObject.
	self acceptNewLiteral! !


!AssignmentTileMorph methodsFor: 'arrow' stamp: 'nk 10/8/2004 14:27'!
addArrowsIfAppropriate
	"If the receiver's slot is of an appropriate type, add arrows to the tile."

	(Vocabulary vocabularyForType: dataType)
		ifNotNilDo:
			[:aVocab | aVocab wantsAssignmentTileVariants ifTrue:
				[self addArrows]].
	(assignmentSuffix = ':') ifTrue:
		[ self addMorphBack: (ImageMorph new image: (ScriptingSystem formAtKey: #NewGets)).
		(self findA: StringMorph) ifNotNilDo: [ :sm |
			(sm contents endsWith: ' :') ifTrue: [ sm contents: (sm contents allButLast: 2) ]]]! !


!AssignmentTileMorph methodsFor: 'as yet unclassified'!
fixLayoutOfSubmorphsNotIn: aCollection 
	super fixLayoutOfSubmorphsNotIn: aCollection.
	self updateLiteralLabel; updateWordingToMatchVocabulary; layoutChanged; fullBounds! !


!AssignmentTileMorph methodsFor: 'code generation' stamp: 'sw 2/6/2002 01:17'!
assignmentReceiverTile
	"Answer the TilePadMorph that should be sent storeCodeOn:indent: to get the receiver of the assignment properly stored on the code stream"

	^ owner submorphs first! !

!AssignmentTileMorph methodsFor: 'code generation' stamp: 'sw 2/6/2002 01:25'!
operatorForAssignmentSuffix: aString
	"Answer the operator associated with the receiver, assumed to be one of the compound assignments"

	| toTest |
	toTest _ aString asString.
	#(	('Incr:'				'+')
		('Decr:'				'-')
		('Mult:'				'*'))
	do:
		[:pair | toTest = pair first ifTrue: [^ pair second]].
	^ toTest

	"AssignmentTileMorph new operatorForAssignmentSuffix: 'Incr:'"! !

!AssignmentTileMorph methodsFor: 'code generation' stamp: 'aoy 2/15/2003 21:09'!
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"
aStream nextPutAll: (Utilities setterSelectorFor: assignmentRoot).
			aStream space."Simple assignment, don't need existing value"
	assignmentSuffix = ':' 

		ifFalse: 
			["Assignments that require that old values be retrieved"

			
			self assignmentReceiverTile storeCodeOn: aStream indent: tabCount.
			aStream space.
			aStream nextPutAll: (Utilities getterSelectorFor: assignmentRoot).
			aStream space.
			aStream nextPutAll: (self operatorForAssignmentSuffix: assignmentSuffix).
			aStream space]! !


!AssignmentTileMorph methodsFor: 'initialization' stamp: 'yo 1/30/2005 11:11'!
computeOperatorOrExpression
	"Compute the operator or expression to use, and set the wording correectly on the tile face"

	| aSuffix wording anInterface getter doc |
	operatorOrExpression _ (assignmentRoot, assignmentSuffix) asSymbol.
	aSuffix _ self currentVocabulary translatedWordingFor:  assignmentSuffix.
	getter _ Utilities getterSelectorFor: assignmentRoot.
	anInterface _ self currentVocabulary methodInterfaceAt: getter ifAbsent: [Vocabulary eToyVocabulary methodInterfaceAt: getter ifAbsent: [nil]].
	wording _ anInterface ifNotNil: [anInterface wording] ifNil: [assignmentRoot copyWithout: $:].
	(anInterface notNil and: [(doc _ anInterface documentation) notNil])
		ifTrue:
			[self setBalloonText: doc].
	operatorReadoutString _ wording translated, ' ', aSuffix.
 	self line1: operatorReadoutString.
	self addArrowsIfAppropriate! !

!AssignmentTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:44'!
initialize
"initialize the state of the receiver"
	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: 'yo 1/1/2004 19:50'!
setRoot: aString
	"Establish the assignment root, and update the label on the tile"

	assignmentRoot _ aString.
	self updateLiteralLabel! !

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

!AssignmentTileMorph methodsFor: 'initialization' stamp: 'sw 9/12/2001 22:52'!
updateWordingToMatchVocabulary
	"The current vocabulary has changed; change the wording on my face, if appropriate"

	self computeOperatorOrExpression! !


!AssignmentTileMorph methodsFor: 'player viewer' stamp: 'yo 1/1/2004 19:51'!
assignmentRoot
	"Answer the assignment root"

	^ assignmentRoot! !

!AssignmentTileMorph methodsFor: 'player viewer' 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: 'comparing' stamp: 'md 1/27/2004 17:27'!
= anAssociation

	^ super = anAssociation and: [value = anAssociation value]! !

!Association methodsFor: 'comparing' stamp: 'md 1/27/2004 17:28'!
hash
	"Hash is reimplemented because = is implemented."
	
	^key hash bitXor: value hash.! !


!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 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: 'self evaluating' stamp: 'sd 7/31/2005 21:44'!
isSelfEvaluating
	^ self class == Association! !


!Association methodsFor: 'testing' stamp: 'ar 8/14/2001 23:06'!
isSpecialWriteBinding
	"Return true if this variable binding is write protected, e.g., should not be accessed primitively but rather by sending #value: messages"
	^false! !

!Association methodsFor: 'testing' stamp: 'ar 8/14/2001 22:39'!
isVariableBinding
	"Return true if I represent a literal variable binding"
	^true! !


!Association methodsFor: '*services-base-preferences' stamp: 'rr 3/21/2006 11:58'!
serviceUpdate
	self key service perform: self value! !

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

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! !
ClassTestCase subclass: #AssociationTest
	instanceVariableNames: 'a b'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Support'!

!AssociationTest methodsFor: 'setup' stamp: 'zz 12/5/2005 18:33'!
setUp

	a := 1 -> 'one'.
	b := 1 -> 'een'.! !


!AssociationTest methodsFor: 'tests' stamp: 'md 3/8/2004 16:37'!
testEquality
	
	self 
		assert: (a key = b key);
		deny: (a value = b value);
		deny: (a = b)

! !

!AssociationTest methodsFor: 'tests' stamp: 'md 3/8/2004 16:38'!
testHash

	self 
		assert: (a hash = a copy hash);
		deny: (a hash = b hash)! !

!AssociationTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:38'!
testIsSelfEvaluating
	self 
		assert: (a isSelfEvaluating)
! !
Object subclass: #AsyncFile
	instanceVariableNames: 'name writeable semaphore fileHandle'
	classVariableNames: 'Busy ErrorCode'
	poolDictionaries: ''
	category: 'Files-Kernel'!
!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: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'!
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: 'stephaneducasse 2/4/2006 20:31'!
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: 'bootstrap 5/31/2006 20:46'!
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 = ErrorCode ifTrue: [^ self error: 'asynchronous read operation failed'].
		aBlock value: buffer.
	] forkAt: Processor userInterruptPriority.
! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'!
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: ( FileDirectory default fullNameFor: fileName) forWrite: true.
	self primWriteStart: fileHandle
		fPosition: 0
		fromBuffer: buf1
		at: 1
		count: byteCount.
	semaphore wait.
	bytesWritten := self primWriteResult: fileHandle.
	self close.
	
	self open: ( FileDirectory default fullNameFor: 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: 'bootstrap 5/31/2006 20:45'!
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 = ErrorCode 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 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 class
	instanceVariableNames: ''!

!AsyncFile class methodsFor: 'class initialization' stamp: 'bootstrap 5/31/2006 20:45'!
initialize
	"AsyncFile initialize"

	"Possible abnormal I/O completion results."
	Busy := -1.
	ErrorCode := -2.
! !
EllipseMorph subclass: #AtomMorph
	instanceVariableNames: 'velocity'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Demo'!
!AtomMorph commentStamp: 'tbn 11/25/2004 09:06' prior: 0!
AtomMorph represents an atom used in the simulation of
an ideal gas. It's container is typically a BouncingAtomsMorph.

Try:

	BouncingAtomsMorph  new openInWorld

to open the gas simulation or:

	AtomMorph example

to open an instance in the current world!


!AtomMorph methodsFor: 'accessing'!
infected

	^ color = Color red! !

!AtomMorph methodsFor: 'accessing'!
infected: aBoolean

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

!AtomMorph methodsFor: 'accessing'!
velocity

	^ velocity! !

!AtomMorph methodsFor: 'accessing'!
velocity: newVelocity

	velocity _ newVelocity.! !


!AtomMorph methodsFor: 'drawing'!
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: 'initialization' stamp: 'dgd 3/7/2003 14:13'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 0! !

!AtomMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:13'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color blue! !

!AtomMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:13'!
initialize
	"Make a new atom with a random position and velocity."
	super initialize.
""
	self extent: 8 @ 7.
	
	self
		randomPositionIn: (0 @ 0 corner: 300 @ 300)
		maxVelocity: 10! !

!AtomMorph methodsFor: 'initialization' 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: 'private' 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 class
	instanceVariableNames: ''!

!AtomMorph class methodsFor: 'examples' stamp: 'tbn 11/25/2004 09:03'!
example
	"
	AtomMorph example
	"
	|a|
	a := AtomMorph new openInWorld. 
	a color: Color random.
 	[1000 timesRepeat:  [a bounceIn: World bounds.  (Delay forMilliseconds: 50) wait]. 
	 a delete] fork.! !


!AtomMorph class methodsFor: 'new-morph participation' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
Error subclass: #AttemptToWriteReadOnlyGlobal
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Exceptions-Kernel'!
!AttemptToWriteReadOnlyGlobal commentStamp: 'gh 5/2/2002 20:26' prior: 0!
This is a resumable error you get if you try to assign a readonly variable a value.
Name definitions in the module system can be read only and are then created using instances of ReadOnlyVariableBinding instead of Association.
See also LookupKey>>beReadWriteBinding and LookupKey>>beReadOnlyBinding.

!


!AttemptToWriteReadOnlyGlobal methodsFor: 'as yet unclassified' stamp: 'ar 8/17/2001 18:02'!
description
	"Return a textual description of the exception."

	| desc mt |
	desc := 'Error'.
	^(mt := self messageText) == nil
		ifTrue: [desc]
		ifFalse: [desc, ': ', mt]! !

!AttemptToWriteReadOnlyGlobal methodsFor: 'as yet unclassified' stamp: 'ar 8/17/2001 18:02'!
isResumable
	^true! !
Stream subclass: #AttributedTextStream
	instanceVariableNames: 'characters attributeRuns attributeValues currentAttributes currentRun'
	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: 'access' stamp: 'ls 6/27/1998 15:09'!
currentAttributes
	"return the current attributes"
	^currentAttributes! !

!AttributedTextStream methodsFor: 'access' stamp: 'ar 10/16/2001 22:57'!
currentAttributes: newAttributes
	"set the current attributes"
	(currentRun > 0 and:[currentAttributes ~= newAttributes]) ifTrue:[
		attributeRuns nextPut: currentRun.
		attributeValues nextPut: currentAttributes.
		currentRun _ 0.
	].
	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: 'retrieving the text' stamp: 'ar 10/16/2001 22:39'!
contents
	| ans |
	currentRun > 0 ifTrue:[
		attributeValues nextPut: currentAttributes.
		attributeRuns nextPut: currentRun.
		currentRun _ 0].
	ans _ Text new: characters size.
	"this is declared private, but it's exactly what I need, and it's declared as exactly what I want it to do...."
	ans setString: characters contents  setRuns: 
		(RunArray runs: attributeRuns contents values: attributeValues contents).
	^ans! !


!AttributedTextStream methodsFor: 'stream protocol' stamp: 'ar 10/16/2001 22:38'!
nextPut: aChar
	currentRun _ currentRun + 1.
	characters nextPut: aChar! !

!AttributedTextStream methodsFor: 'stream protocol' stamp: 'ar 10/16/2001 22:38'!
nextPutAll: aString
	"add an entire string with the same attributes"
	currentRun _ currentRun + aString size.
	characters nextPutAll: aString.! !


!AttributedTextStream methodsFor: 'private-initialization' stamp: 'ar 10/16/2001 22:40'!
initialize
	characters _ WriteStream on: String new.
	currentAttributes _ OrderedCollection new.
	currentRun _ 0.
	attributeValues _ WriteStream on: (Array new: 50).
	attributeRuns _ WriteStream on: (Array new: 50).	! !

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

AttributedTextStream class
	instanceVariableNames: ''!

!AttributedTextStream class methodsFor: 'instance creation' stamp: 'gk 2/9/2004 18:50'!
new
	"For this class we override Stream class>>new since this
	class actually is created using #new, even though it is a Stream."
	
	^self 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: 'Nebraska-Morphic-Collaborative'!

!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: 'dgd 2/14/2003 22:36'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 4! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color yellow! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	transmitWhileRecording := false.
	handsFreeTalking := false.
	mycodec := GSMCodec new.
	myrecorder := ChatNotes new.
	mytargetip := ''.
	
	self start2.
	self changeTalkButtonLabel! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
ipAddress: aString

	mytargetip := aString! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:25'!
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: 'sd 11/20/2005 21: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: 'sd 11/20/2005 21:25'!
handsFreeTalking

	^handsFreeTalking ifNil: [handsFreeTalking := false].! !

!AudioChatGUI methodsFor: 'sending' stamp: 'sd 11/20/2005 21:25'!
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: 'sd 11/20/2005 21:25'!
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: 'sd 11/20/2005 21:25'!
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: 'sd 11/20/2005 21:25'!
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: 'sd 11/20/2005 21:25'!
transmitWhileRecording

	^transmitWhileRecording ifNil: [transmitWhileRecording := false]! !


!AudioChatGUI methodsFor: 'stepping and presenter' stamp: 'sd 11/20/2005 21:25'!
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: 'stepping and presenter' stamp: 'sd 11/20/2005 21:25'!
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: 'stepping and presenter' stamp: 'Tbp 4/11/2000 16:49'!
stop

	myrecorder stop.
	self send.! !


!AudioChatGUI methodsFor: 'stuff' stamp: 'aoy 2/17/2003 01:01'!
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.'].
	bText := transmitWhileRecording 
		ifTrue: [bText , ' The message will be sent while you are speaking.']
		ifFalse: [bText , ' The message will be sent when you are finished.'].
	theTalkButton setBalloonText: bText! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'sd 11/20/2005 21: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: '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: '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: 'sd 11/20/2005 21:25'!
removeConnectButton

	theConnectButton ifNotNil: [
		theConnectButton delete.
		theConnectButton := nil.
	].! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'sd 11/20/2005 21:25'!
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: 'testing' stamp: 'RAA 8/12/2000 18:09'!
stepTime

	myrecorder ifNil: [^200].
	myrecorder isRecording ifFalse: [^200].
	^20! !

!AudioChatGUI methodsFor: 'testing' stamp: 'RAA 8/2/2000 07:47'!
stepTimeIn: aSystemWindow

	^self stepTime
! !


!AudioChatGUI methodsFor: 'user interface' 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: 'user interface' 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 class
	instanceVariableNames: ''!

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
debugLog: x
"
AudioChatGUI debugLog: nil
AudioChatGUI debugLog: OrderedCollection new
DebugLog LiveMessages NewAudioMessages PlayOnArrival 
"
	DebugLog := x.
! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
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: 'sd 11/20/2005 21:26'!
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: 'sd 11/20/2005 21:26'!
newAudioMessages

	^NewAudioMessages ifNil: [NewAudioMessages := SharedQueue new].! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
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/6/2000 14:23'!
playNextAudioMessage

	(self newAudioMessages nextOrNil ifNil: [^self]) asSound play.! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
playOnArrival

	^PlayOnArrival ifNil: [PlayOnArrival := false]! !


!AudioChatGUI class methodsFor: 'class initialization' 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: 'creation' stamp: 'RAA 8/4/2000 14:06'!
openAsMorph

	AudioChatGUI new openInWorld.	"old syswindow version in #start"

! !


!AudioChatGUI class methodsFor: 'parts bin' stamp: 'md 8/10/2006 11:53'!
descriptionForPartsBin
	"Answer a description of the receiver for use in a parts bin"

	^ self partName: 	'Audio chat'
		categories:		#('Collaborative')
		documentation:	'A tool for talking to other Squeak users'
		sampleImageForm: (Form
	extent: 110@70
	depth: 8
	fromArray: #( 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193845248 4193909241 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33159673 4193845248 4193909241 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843257 4193845248 4193908993 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 4193845248 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33095680 4193845505 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 33095680 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642629 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466465 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2239817189 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 2246173153 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857024481 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857013729 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783321061 3842048257 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 31843813 31843813 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783321061 31843813 3857048833 16901605 3842106625 31843813 3842106625 31843813 3842048257 3857049061 16901605 16843237 3857048960 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 31843813 3856990693 3856990693 16843237 3842106853 16843237 3842106853 31843813 31843585 3856990693 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3777505320 673720360 673720360 685891880 673720360 673720360 673720545 3777505320 673720360 673720360 685892065 3783321061 31843813 3856990693 3856990693 3842106853 3842106853 3842106853 3842106853 16843009 31785445 3857049061 3842106853 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783648741 31843813 3856990693 3856990693 3842106853 3842106853 3842106853 3842106853 31843813 3856990693 3857049061 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783321061 31843813 31785445 3856990693 3842106853 3842106853 3842106853 3842106853 31843813 31843585 3856990693 3842106853 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783648741 3842048257 3857048833 16901605 16843237 16843237 16843237 16843237 3842048257 3857049061 16901605 3856990693 3857048965 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783321061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857013729 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789653477 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857024481 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 2239817189 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 2246173153 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 3789642629 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466465 3789677025 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 3789677025 3789677025 3789676928 2239792512 2239792512 2239792512 2239792512 2239792512 2239816161 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3777505320 673720360 673720360 685891880 673720360 673720360 673720545 3777505320 673720360 673720360 685892065 3789677025 3789677025 3789677025 3783613413 3857049061 3857049061 3857049061 3857049061 3857049061 3857013637 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 16843009 16843009 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3842048257 16901605 16901605 3857049061 3857049061 3857049061 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789619457 16843009 16843009 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3856990693 3842106853 3857049061 3857049061 3857049061 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 16843009 1888776340 1888776340 1879113985 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990693 3856990693 3842106853 3842048257 3857048833 16901377 16901605 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789676801 16880752 2490406000 2490406000 2490405889 16900577 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3856990693 3842106853 31843813 31843813 31843813 31843813 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 26505364 1888776340 1888776340 1888776340 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990465 16901605 3842106853 3842048257 31843813 3842106625 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 2490406000 2490406000 2490406000 2490406000 2483093985 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3857049061 3842106853 31843813 31843813 3842106625 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939540 1888776340 1888776340 1888776340 1888776340 1888747777 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990693 3857049061 3842106853 31843813 31843813 3856990693 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939504 2490406000 2490406000 2490406000 2490406000 2490368257 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3842048257 3857049061 16843237 3842048257 3842106853 3856990693 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3774939393 3789677025 16871572 1888776340 1895825407 1888776340 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3783613413 3857049061 3857049061 3857049061 3857049061 3857049061 3857013637 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 2239792512 2239792512 2239792512 2239792512 2239792512 2239816161 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1535466373 1535466373 1535466373 1535466373 1535466373 1541530081 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3774939393 3789677025 16880752 2490406000 2499805183 2490406000 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789653376 3857049061 3857049061 3857049061 3857049061 3857049061 3850405345 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 16871572 1888776340 1888776340 1888776340 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 3857049061 3857049061 3857049061 3857049061 3857049061 3857048965 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939504 2490406000 2490406000 2490406000 2490406000 2490368257 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939540 1888776340 1888776340 1888776340 1888776340 1888747777 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1541793253 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 1541530081 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 2490406000 2490406000 2490406000 2490406000 2483093985 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3856990465 16843237 3857049061 3857048833 31843813 31843813 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 26505364 1888776340 1888776340 1888776340 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3856990693 31785445 3857049061 3857049061 31843585 31843813 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789676801 16880752 2490406000 2490406000 2490405889 16900577 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 3842048257 3857049061 31843813 31843585 31843813 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 16843009 1888776340 1888776340 1879113985 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 31843813 31843813 31843813 31843813 31785445 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789619457 16843009 16843009 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 3842048257 31843813 31843813 16901605 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 16843009 16843009 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 31843813 31843813 31843813 31843813 31785445 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 31843813 31843813 31843813 31843585 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857048833 16901605 3842048257 3842106625 16901377 16901377 31843813 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1541793253 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 1541530081 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 3857049061 3857049061 3857049061 3857049061 3857049061 3857048965 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653376 3857049061 3857049061 3857049061 3857049061 3857049061 3850405345 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1535466373 1535466373 1535466373 1535466373 1535466373 1541530081 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 16842752 4193845505 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 33095680 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33095680 4193908993 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 4193845248 4193909241 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843257 4193845248 4193909241 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33159673 4193845248)
	offset: 0@0)! !
Object subclass: #Authorizer
	instanceVariableNames: 'users realm'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!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: '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: 'ar 8/17/2001 18:19'!
user: userId
	"Return the requesting user."
	^users at: userId ifAbsent: [ self error: (self class unauthorizedFor: realm) ]! !


!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 class
	instanceVariableNames: ''!

!Authorizer class methodsFor: 'as yet unclassified' stamp: 'ar 8/17/2001 18:19'!
unauthorizedFor: realm
	^'HTTP/1.0 401 Unauthorized', self crlf, 'WWW-Authenticate: Basic realm="Squeak/',realm,'"',
	String crlfcrlf, '<html><title>Unauthorized</title><body><h2>Unauthorized for ',realm, '</h2></body></html>'

! !
Object subclass: #AutoStart
	instanceVariableNames: 'parameters'
	classVariableNames: 'Active InstalledLaunchers'
	poolDictionaries: ''
	category: 'System-Support'!

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

AutoStart class
	instanceVariableNames: ''!

!AutoStart class methodsFor: 'accessing' stamp: 'mir 7/28/1999 17:47'!
addLauncher: launcher
	self installedLaunchers add: launcher! !

!AutoStart class methodsFor: 'accessing'!
addLauncherFirst: launcher
	self installedLaunchers addFirst: launcher! !

!AutoStart class methodsFor: 'accessing' stamp: 'mir 7/28/1999 17:47'!
removeLauncher: launcher
	self installedLaunchers remove: launcher ifAbsent: []! !


!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 9/30/2004 15:05'!
initialize
	"AutoStart initialize"
	"Order: ExternalSettings, SecurityManager, AutoStart"
	Smalltalk addToStartUpList: AutoStart after: SecurityManager.
	Smalltalk addToShutDownList: AutoStart after: SecurityManager.! !

!AutoStart class methodsFor: 'class initialization' stamp: 'mir 9/30/2004 15:06'!
shutDown: quitting
	self active: false! !

!AutoStart class methodsFor: 'class initialization' stamp: 'bf 11/23/2004 19:01'!
startUp: resuming
	"The image is either being newly started (resuming is true), or it's just been snapshotted.
	If this has just been a snapshot, skip all the startup stuff."

	| startupParameters launchers |
	self active ifTrue: [^self].
	self active: true.
	resuming ifFalse: [^self].

	HTTPClient determineIfRunningInBrowser.
	startupParameters _ AbstractLauncher extractParameters.
	(startupParameters includesKey: 'apiSupported' asUppercase )
		ifTrue: [
			HTTPClient browserSupportsAPI: ((startupParameters at: 'apiSupported' asUppercase) asUppercase = 'TRUE').
			HTTPClient isRunningInBrowser
				ifFalse: [HTTPClient isRunningInBrowser: true]].
	self checkForUpdates
		ifTrue: [^self].
	self checkForPluginUpdate.
	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] fixTemps]]! !


!AutoStart class methodsFor: 'updating' stamp: 'mir 3/5/2004 20:43'!
checkForPluginUpdate
	| pluginVersion updateURL |
	World 
		ifNotNil: [
			World install.
			ActiveHand position: 100@100].
	HTTPClient isRunningInBrowser
		ifFalse: [^false].
	pluginVersion _ AbstractLauncher extractParameters
		at: (SmalltalkImage current platformName copyWithout: Character space) asUppercase
		ifAbsent: [^false].
	updateURL _ AbstractLauncher extractParameters
		at: 'UPDATE_URL'
		ifAbsent: [^false].
	^SystemVersion check: pluginVersion andRequestPluginUpdate: updateURL! !

!AutoStart class methodsFor: 'updating' stamp: 'mir 11/13/2003 19:09'!
checkForUpdates
	| availableUpdate updateServer |
	World 
		ifNotNil: [
			World install.
			ActiveHand position: 100@100].
	HTTPClient isRunningInBrowser
		ifFalse: [^self processUpdates].
	availableUpdate _ (AbstractLauncher extractParameters
		at: 'UPDATE'
		ifAbsent: [''] ) asInteger.
	availableUpdate
		ifNil: [^false].
	updateServer _ AbstractLauncher extractParameters
		at: 'UPDATESERVER'
		ifAbsent: [AbstractLauncher extractParameters
		at: 'UPDATE_SERVER'
		ifAbsent: ['Squeakland']].
	Utilities setUpdateServer: updateServer.
	^SystemVersion checkAndApplyUpdates: availableUpdate! !

!AutoStart class methodsFor: 'updating' stamp: 'CdG 10/17/2005 19:34'!
processUpdates
	"Process update files from a well-known update server.  This method is called at system startup time,   Only if the preference #updateFromServerAtStartup is true is the actual update processing undertaken automatically"
	| choice |
	(Preferences valueOfFlag: #updateFromServerAtStartup) ifTrue:
		[choice _ UIManager default chooseFrom: #('Yes, Update' 'No, Not now' 'Don''t ask again')
			title: 'Shall I look for new code\updates on the server?' withCRs.
		choice = 1 ifTrue: [
			Utilities updateFromServer].
		choice = 3 ifTrue: [
			Preferences setPreference: #updateFromServerAtStartup toValue: false.
			self inform: 'Remember to save you image to make this setting permant.']].
	^false! !


!AutoStart class methodsFor: 'private' stamp: 'mir 9/7/2004 13:34'!
active
	^ Active == true! !

!AutoStart class methodsFor: 'private' stamp: 'mir 9/7/2004 13:36'!
active: aBoolean
	Active := aBoolean! !

!AutoStart class methodsFor: 'private' stamp: 'mir 7/28/1999 17:43'!
installedLaunchers
	InstalledLaunchers ifNil: [
		InstalledLaunchers _ OrderedCollection new].
	^InstalledLaunchers! !
Object subclass: #BDFFontReader
	instanceVariableNames: 'file properties'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Fonts'!
!BDFFontReader commentStamp: '<historical>' prior: 0!
I am a conversion utility for reading X11 Bitmap Distribution Format fonts.  My code is derived from the multilingual Squeak changeset written by OHSHIMA Yoshiki (ohshima@is.titech.ac.jp), although all support for fonts with more than 256 glyphs has been ripped out.  See http://www.is.titech.ac.jp/~ohshima/squeak/squeak-multilingual-e.html .

My class methods contain tools for fetching BDF source files from a well-known archive site, batch conversion to Squeak's .sf2 format, and installation of these fonts as TextStyles.  Also, the legal notices for the standard 75dpi fonts I process this way are included as "x11FontLegalNotices'.!


!BDFFontReader methodsFor: 'initialize' stamp: 'nop 1/18/2000 19:44'!
initialize
	properties _ Dictionary new.! !

!BDFFontReader methodsFor: 'initialize' stamp: 'ar 10/25/2005 00:34'!
openFileNamed: fileName
	file := CrLfFileStream readOnlyFileNamed: fileName.! !


!BDFFontReader methodsFor: 'reading' stamp: 'nop 1/18/2000 19:45'!
errorFileFormat
	self error: 'malformed bdf format'! !

!BDFFontReader methodsFor: 'reading' stamp: 'nop 1/18/2000 19:46'!
errorUnsupported
	self error: 'unsupported bdf'! !

!BDFFontReader methodsFor: 'reading' stamp: 'ar 10/25/2005 00:35'!
getLine
	^file upTo: Character cr.! !

!BDFFontReader methodsFor: 'reading' stamp: 'ar 10/25/2005 00:35'!
read
	| xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width blt lastAscii pointSize ret stream |
	form _ encoding _ bbx _ nil.
	self readAttributes.
	height _ Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2).
	ascent _ Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first.
	descent _ Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first.
	pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10.
	
	maxWidth _ 0.
	minAscii _ 9999.
	strikeWidth _ 0.
	maxAscii _ 0.

	charsNum _ Integer readFromString: (properties at: #CHARS) first.
	chars _ Set new: charsNum.

	1 to: charsNum do: [:i |
		array _ self readOneCharacter.
		stream _ ReadStream on: array.
		form _ stream next.
		encoding _ stream next.
		bbx _ stream next.
		form ifNotNil: [
			width _ bbx at: 1.
			maxWidth _ maxWidth max: width.
			minAscii _ minAscii min: encoding.
			maxAscii _ maxAscii max: encoding.
			strikeWidth _ strikeWidth + width.
			chars add: array.
		].
	].

	chars _ chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)].
	charsNum _ chars size. "undefined encodings make this different"

	charsNum > 256 ifTrue: [
		"it should be 94x94 charset, and should be fixed width font"
		strikeWidth _ 94*94*maxWidth.
		maxAscii _ 94*94.
		minAscii _ 0.
		xTable _ XTableForFixedFont new.
		xTable maxAscii: 94*94.
		xTable width: maxWidth.
	] ifFalse: [
		xTable _ (Array new: 258) atAllPut: 0.
	].

	glyphs _ Form extent: strikeWidth@height.
	blt _ BitBlt toForm: glyphs.
	lastAscii _ 0.
	
	charsNum > 256 ifTrue: [
		1 to: charsNum do: [:i |
			stream _ ReadStream on: (chars at: i).
			form _ stream next.
			encoding _ stream next.
			bbx _ stream next.
			encoding _ ((encoding // 256) - 33) * 94 + ((encoding \\ 256) - 33).
			blt copy: ((encoding * maxWidth)@0 extent: maxWidth@height)
				from: 0@0 in: form.
		].
	] ifFalse: [
		1 to: charsNum do: [:i |
			stream _ ReadStream on: (chars at: i).
			form _ stream next.
			encoding _ stream next.
			bbx _ stream next.
			lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)].
			blt copy: (((xTable at: encoding+1)@(ascent - (bbx at: 2) - (bbx at: 4)))
					extent: (bbx at: 1)@(bbx at: 2))
				from: 0@0 in: form.
			xTable at: encoding+2 put: (xTable at: encoding+1)+(bbx at: 1).
			lastAscii _ encoding.
		]
	].

	ret _ Array new: 8.
	ret at: 1 put: xTable.
	ret at: 2 put: glyphs.
	ret at: 3 put: minAscii.
	ret at: 4 put: maxAscii.
	ret at: 5 put: maxWidth.
	ret at: 6 put: ascent.
	ret at: 7 put: descent.
	ret at: 8 put: pointSize.
	^ret.
" ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}"
! !

!BDFFontReader methodsFor: 'reading' stamp: 'ar 10/25/2005 00:35'!
readAttributes
	| str a |
	"I don't handle double-quotes correctly, but it works"
	file reset.
	[file atEnd] whileFalse: [
		str _ self getLine.
		(str beginsWith: 'STARTCHAR') ifTrue: [file skip: (0 - str size - 1). ^self].
		a _ str substrings.
		properties at: a first asSymbol put: a allButFirst.
	].
	self error: 'file seems corrupted'.! !

!BDFFontReader methodsFor: 'reading' stamp: 'ar 10/25/2005 00:35'!
readChars
	| strikeWidth ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width pointSize stream |
	form _ encoding _ bbx _ nil.
	self readAttributes.
	height _ Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2).
	ascent _ Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first.
	descent _ Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first.
	pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10.
	
	maxWidth _ 0.
	minAscii _ 9999.
	strikeWidth _ 0.
	maxAscii _ 0.

	charsNum _ Integer readFromString: (properties at: #CHARS) first.
	chars _ Set new: charsNum.

	1 to: charsNum do: [:i |
		array _ self readOneCharacter.
		stream _ ReadStream on: array.
		form _ stream next.
		encoding _ stream next.
		bbx _ stream next.
		form ifNotNil: [
			width _ bbx at: 1.
			maxWidth _ maxWidth max: width.
			minAscii _ minAscii min: encoding.
			maxAscii _ maxAscii max: encoding.
			strikeWidth _ strikeWidth + width.
			chars add: array.
		].
	].

	chars _ chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)].

	^ chars.
! !

!BDFFontReader methodsFor: 'reading' stamp: 'ar 10/25/2005 00:35'!
readOneCharacter
	| str a encoding bbx form bits hi low pos |
	((str _ self getLine) beginsWith: 'ENDFONT') ifTrue: [^ {nil. nil. nil}].
	(str beginsWith: 'STARTCHAR') ifFalse: [self errorFileFormat].
	((str _ self getLine) beginsWith: 'ENCODING') ifFalse: [self errorFileFormat].
	encoding _ Integer readFromString: str substrings second.
	(self getLine beginsWith: 'SWIDTH') ifFalse: [self errorFileFormat].
	(self getLine beginsWith: 'DWIDTH') ifFalse: [self errorFileFormat].
	
	((str _ self getLine) beginsWith: 'BBX') ifFalse: [self errorFileFormat].
	a _ str substrings.
	bbx _ (2 to: 5) collect: [:i | Integer readFromString: (a at: i)].
	((str _ self getLine) beginsWith: 'ATTRIBUTES') ifTrue: [str _ self getLine].
	(str beginsWith: 'BITMAP') ifFalse: [self errorFileFormat].

	form _ Form extent: (bbx at: 1)@(bbx at: 2).
	bits _ form bits.
	pos _ 0.
	1 to: (bbx at: 2) do: [:t |
		1 to: (((bbx at: 1) - 1) // 8 + 1) do: [:i |
			hi _ (('0123456789ABCDEF' indexOf: (file next asUppercase)) - 1) bitShift: 4.
			low _ ('0123456789ABCDEF' indexOf: (file next asUppercase)) - 1.
			
			bits byteAt: (pos+i) put: (hi+low).
		].
		file next ~= Character cr ifTrue: [self errorFileFormat].
		pos _ pos + ((((bbx at: 1) // 32) + 1) * 4).
	].

	(self getLine beginsWith: 'ENDCHAR') ifFalse: [self errorFileFormat].

	encoding < 0 ifTrue: [^{nil. nil. nil}].
	^{form. encoding. bbx}.
	
	
	! !

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

BDFFontReader class
	instanceVariableNames: ''!

!BDFFontReader class methodsFor: 'documentation' stamp: 'nop 2/11/2001 00:22'!
gettingAndInstallingTheFonts

	"Download the 1.3M of BDF font source files from x.org:

		BDFFontReader downloadFonts.

	Convert them to .sf2 StrikeFont files:

		BDFFontReader convertX11FontsToStrike2.

	Install them into the system as TextStyles:

		BDFFontReader installX11Fonts.

	Read the legal notices in 'BDFFontReader x11FontLegalNotices' before
	redistributing images containing these fonts."! !

!BDFFontReader class methodsFor: 'documentation' stamp: 'nop 1/23/2000 18:30'!
x11FontLegalNotices

	^ 'The X11 BDF fonts contain copyright and license information as comments in the
font source code.  For the font family files "cour" (Courier), "helv" (Helvetica), "ncen" (New Century Schoolbook), and "tim" (Times Roman) the notice reads:

COMMENT  Copyright 1984-1989, 1994 Adobe Systems Incorporated.
COMMENT  Copyright 1988, 1994 Digital Equipment Corporation.
COMMENT
COMMENT  Adobe is a trademark of Adobe Systems Incorporated which may be
COMMENT  registered in certain jurisdictions.
COMMENT  Permission to use these trademarks is hereby granted only in
COMMENT  association with the images described in this file.
COMMENT
COMMENT  Permission to use, copy, modify, distribute and sell this software
COMMENT  and its documentation for any purpose and without fee is hereby
COMMENT  granted, provided that the above copyright notices appear in all
COMMENT  copies and that both those copyright notices and this permission
COMMENT  notice appear in supporting documentation, and that the names of
COMMENT  Adobe Systems and Digital Equipment Corporation not be used in
COMMENT  advertising or publicity pertaining to distribution of the software
COMMENT  without specific, written prior permission.  Adobe Systems and
COMMENT  Digital Equipment Corporation make no representations about the
COMMENT  suitability of this software for any purpose.  It is provided "as
COMMENT  is" without express or implied warranty.

For the font family files "char" (Charter), the notice reads:

COMMENT  Copyright 1988 Bitstream, Inc., Cambridge, Massachusetts, USA
COMMENT  Bitstream and Charter are registered trademarks of Bitstream, Inc.
COMMENT  
COMMENT  The names "Bitstream" and "Charter" are registered trademarks of
COMMENT  Bitstream, Inc.  Permission to use these trademarks is hereby
COMMENT  granted only in association with the images described in this file.
COMMENT  
COMMENT  Permission to use, copy, modify, and distribute this software and
COMMENT  its documentation for any purpose and without fee is hereby
COMMENT  granted, provided that the above copyright notice appear in all
COMMENT  copies and that both that copyright notice and this permission
COMMENT  notice appear in supporting documentation, and that the name of
COMMENT  Bitstream not be used in advertising or publicity pertaining to
COMMENT  distribution of the software without specific, written prior
COMMENT  permission.  Bitstream makes no representations about the
COMMENT  suitability of this software for any purpose.  It is provided "as
COMMENT  is" without express or implied warranty.
COMMENT  
COMMENT  BITSTREAM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
COMMENT  INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN
COMMENT  NO EVENT SHALL BITSTREAM BE LIABLE FOR ANY SPECIAL, INDIRECT OR
COMMENT  CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
COMMENT  OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
COMMENT  NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
COMMENT  CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

For the font family files "lu" (Lucida), "lub" (Lucida Bright), and "lut" (Lucida Typewriter),
the notice reads:

COMMENT  (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered
COMMENT  trademark of Bigelow & Holmes. See LEGAL NOTICE file for terms 
COMMENT  of the license. 

The LEGAL NOTICE contains:

This is the LEGAL NOTICE pertaining to the Lucida fonts from Bigelow & Holmes:

	NOTICE TO USER: The source code, including the glyphs or icons 
	forming a par of the OPEN LOOK TM Graphic User Interface, on this 
	tape and in these files is copyrighted under U.S. and international
	laws. Sun Microsystems, Inc. of Mountain View, California owns
	the copyright and has design patents pending on many of the icons. 
	AT&T is the owner of the OPEN LOOK trademark associated with the
	materials on this tape. Users and possessors of this source code 
	are hereby granted a nonexclusive, royalty-free copyright and 
	design patent license to use this code in individual and 
	commercial software. A royalty-free, nonexclusive trademark
	license to refer to the code and output as "OPEN LOOK" compatible 
	is available from AT&T if, and only if, the appearance of the 
	icons or glyphs is not changed in any manner except as absolutely
	necessary to accommodate the standard resolution of the screen or
	other output device, the code and output is not changed except as 
	authorized herein, and the code and output is validated by AT&T. 
	Bigelow & Holmes is the owner of the Lucida (R) trademark for the
	fonts and bit-mapped images associated with the materials on this 
	tape. Users are granted a royalty-free, nonexclusive license to use
	the trademark only to identify the fonts and bit-mapped images if, 
	and only if, the fonts and bit-mapped images are not modified in any
	way by the user. 


	Any use of this source code must include, in the user documentation 
	and internal comments to the code, notices to the end user as  
	follows:


	(c) Copyright 1989 Sun Microsystems, Inc. Sun design patents
	pending in the U.S. and foreign countries. OPEN LOOK is a 
	trademark of AT&T. Used by written permission of the owners.


 	(c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered 
	trademark of Bigelow & Holmes. Permission to use the Lucida 
	trademark is hereby granted only in association with the images 
	and fonts described in this file.



	SUN MICROSYSTEMS, INC., AT&T, AND BIGELOW & HOLMES 
	MAKE NO REPRESENTATIONS ABOUT THE SUITABILITY OF
 	THIS SOURCE CODE FOR ANY PURPOSE. IT IS PROVIDED "AS IS" 
	WITHOUT EXPRESS OR IMPLIED WARRANTY OF ANY KIND. 
	SUN  MICROSYSTEMS, INC., AT&T AND BIGELOW  & HOLMES, 
	SEVERALLY AND INDIVIDUALLY, DISCLAIM ALL WARRANTIES 
	WITH REGARD TO THIS SOURCE CODE, INCLUDING ALL IMPLIED
	WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
	PARTICULAR PURPOSE. IN NO EVENT SHALL SUN MICROSYSTEMS,
	INC., AT&T OR BIGELOW & HOLMES BE LIABLE FOR ANY
	SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES,
	OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA 	
	OR PROFITS, WHETHER IN AN ACTION OF  CONTRACT, NEGLIGENCE
	OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
	WITH THE USE OR PERFORMANCE OF THIS SOURCE CODE.

'.





! !


!BDFFontReader class methodsFor: 'file creation' stamp: 'nop 1/23/2000 19:00'!
convertFilesNamed: fileName toFamilyNamed: familyName inDirectoryNamed: dirName
		"BDFFontReader convertFilesNamed: 'helvR' toFamilyNamed: 'Helvetica' inDirectoryNamed: '' "

	"This utility converts X11 BDF font files to Squeak .sf2 StrikeFont files."

	"For this utility to work as is, the BDF files must be named 'familyNN.bdf',
	and must reside in the directory named by dirName (use '' for the current directory).
	The output StrikeFont files will be named familyNN.sf2, and will be placed in the
	current directory."

	| f allFontNames sizeChars dir |
	"Check for matching file names."
	dir _ dirName isEmpty
		ifTrue: [FileDirectory default]
		ifFalse: [FileDirectory default directoryNamed: dirName].
	allFontNames _ dir fileNamesMatching: fileName , '##.bdf'.
	allFontNames isEmpty ifTrue: [^ self error: 'No files found like ' , fileName , 'NN.bdf'].
	
	Utilities informUserDuring: [:info |
		allFontNames do: [:fname | 
			info value: 'Converting ', familyName, ' BDF file ', fname, ' to SF2 format'.
			sizeChars _ (fname copyFrom: fileName size + 1 to: fname size) copyUpTo: $. .

			f _ StrikeFont new readBDFFromFile: (dir fullNameFor: fname) name: familyName, sizeChars.
			f writeAsStrike2named: familyName, sizeChars, '.sf2'.
		].
	]! !

!BDFFontReader class methodsFor: 'file creation' stamp: 'yo 5/25/2004 10:52'!
new

	^ self basicNew.
! !

!BDFFontReader class methodsFor: 'file creation' stamp: 'ar 10/25/2005 00:21'!
openFileNamed: fileName
	^self new openFileNamed: fileName! !


!BDFFontReader class methodsFor: 'resource download' stamp: 'nop 1/23/2000 18:43'!
convertX11FontsToStrike2  "BDFFontReader convertX11FontsToStrike2"
	"Given a set of standard X11 BDF font files (probably downloaded via BDFFontReader downloadFonts), produce .sf2 format fonts.  The source and destination directory is the current directory."

	"Charter currently tickles a bug in the BDF parser.  Skip it for now."
	"self convertFilesNamed: 'charR' toFamilyNamed: 'Charter' inDirectoryNamed: ''."

	self convertFilesNamed: 'courR' toFamilyNamed: 'Courier' inDirectoryNamed: ''.
	self convertFilesNamed: 'helvR' toFamilyNamed: 'Helvetica' inDirectoryNamed: ''.

	self convertFilesNamed: 'lubR' toFamilyNamed: 'LucidaBright' inDirectoryNamed: ''.
	self convertFilesNamed: 'luRS' toFamilyNamed: 'Lucida' inDirectoryNamed: ''.
	self convertFilesNamed: 'lutRS' toFamilyNamed: 'LucidaTypewriter' inDirectoryNamed: ''.

	self convertFilesNamed: 'ncenR' toFamilyNamed: 'NewCenturySchoolbook' inDirectoryNamed: ''.
	self convertFilesNamed: 'timR' toFamilyNamed: 'TimesRoman' inDirectoryNamed: ''.! !

!BDFFontReader class methodsFor: 'resource download' stamp: 'nop 2/11/2001 00:24'!
downloadFonts  "BDFFontReader downloadFonts"
	"Download a standard set of BDF sources from x.org.  
	The combined size of these source files is around 1.2M; after conversion 
	to .sf2 format they may be deleted."

	| heads tails filenames baseUrl basePath newUrl newPath document f |
	heads _ #( 'charR' 'courR' 'helvR' 'lubR' 'luRS' 'lutRS' 'ncenR' 'timR' ).
	tails _ #( '08' '10' '12' '14' '18' '24').

	filenames _ OrderedCollection new.
	heads do: [:head |
		filenames addAll: (tails collect: [:tail | head , tail , '.bdf'])
	].

	baseUrl _ Url absoluteFromText: 'http://ftp.x.org/pub/R6.4/xc/fonts/bdf/75dpi/'.
	basePath _ baseUrl path.

	filenames do: [:filename |
		newUrl _ baseUrl clone.
		newPath _ OrderedCollection newFrom: basePath.

		newPath addLast: filename.
		newUrl path: newPath.

		Utilities informUser: 'Fetching ' , filename during: 
			[document _ newUrl retrieveContents].

		f _ CrLfFileStream newFileNamed: filename.
		f nextPutAll: document content.
		f close.
	].
! !

!BDFFontReader class methodsFor: 'resource download' stamp: 'nop 1/23/2000 18:44'!
installX11Fonts "BDFFontReader installX11Fonts"
	"Installs previously-converted .sf2 fonts into the TextConstants dictionary.  This makes them available as TextStyles everywhere in the image."

	| families fontArray textStyle |
	families _ #( 'Courier' 'Helvetica' 'LucidaBright' 'Lucida' 'LucidaTypewriter' 'NewCenturySchoolbook' 'TimesRoman' ).

	families do: [:family |
		fontArray _ StrikeFont readStrikeFont2Family: family.
		textStyle _ TextStyle fontArray: fontArray.
		TextConstants at: family asSymbol put: textStyle.
	].
! !
ImageReadWriter subclass: #BMPReadWriter
	instanceVariableNames: 'bfType bfSize bfOffBits biSize biWidth biHeight biPlanes biBitCount biCompression biSizeImage biXPelsPerMeter biYPelsPerMeter biClrUsed biClrImportant'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Files'!

!BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 15:36'!
nextImage
	| colors |
	stream binary.
	self readHeader.
	biBitCount = 24 ifTrue:[^self read24BmpFile].
	"read the color map"
	colors := self readColorMap.
	^self readIndexedBmpFile: colors! !

!BMPReadWriter methodsFor: 'reading' stamp: 'ar 10/25/2005 13:48'!
read24BmpFile
	"Read 24-bit pixel data from the given a BMP stream."
	| form formBits pixelLine bitsIndex bitBlt |
	form _ Form extent: biWidth@biHeight depth: 32.
	pixelLine := ByteArray new: (((24 * biWidth) + 31) // 32) * 4.
	bitsIndex := form height - 1 * biWidth + 1.
	formBits := form bits.
	1 to: biHeight do: [:i |
		pixelLine := stream nextInto: pixelLine.
		self read24BmpLine: pixelLine into: formBits startingAt: bitsIndex width: biWidth.
		bitsIndex := bitsIndex - biWidth.
	].
	bitBlt := BitBlt toForm: form.
	bitBlt combinationRule: 7 "bitOr:with:".
	bitBlt halftoneForm: (Bitmap with: 16rFF000000).
	bitBlt copyBits.
	^ form
! !

!BMPReadWriter methodsFor: 'reading' stamp: 'ar 10/25/2005 13:47'!
read24BmpLine: pixelLine into: formBits startingAt: formBitsIndex width: width
	| pixIndex rgb bitsIndex |
	pixIndex _ 0. "pre-increment"
	bitsIndex := formBitsIndex-1. "pre-increment"
	1 to: width do: [:j |
		rgb := 
			(pixelLine at: (pixIndex := pixIndex+1)) +
			((pixelLine at: (pixIndex := pixIndex+1)) bitShift: 8) +
			((pixelLine at: (pixIndex := pixIndex+1)) bitShift: 16).
		formBits at: (bitsIndex := bitsIndex+1) put: rgb.
	].
! !

!BMPReadWriter methodsFor: 'reading' stamp: 'ar 10/24/2005 20:57'!
readColorMap
	"Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors."
	| colorCount colors maxLevel b g r ccStream |
	colorCount _ (bfOffBits - 54) // 4.
	"Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map"
	biBitCount >= 16 ifTrue:[^nil].
	colorCount = 0 ifTrue: [ "this BMP file does not have a color map"
		"default monochrome color map"
		biBitCount = 1 ifTrue: [^ Array with: Color white with: Color black].
		"default gray-scale color map"
		maxLevel _ (2 raisedTo: biBitCount) - 1.
		^ (0 to: maxLevel) collect: [:level | Color gray: (level asFloat / maxLevel)]].
	ccStream := ReadStream on: (stream next: colorCount*4).
	colors _ Array new: colorCount.
	1 to: colorCount do: [:i |
		b _ ccStream next.
		g _ ccStream next.
		r _ ccStream next.
		ccStream next. "skip reserved"
		colors at: i put: (Color r: r g: g b: b range: 255)].
	^ colors
! !

!BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 15:20'!
readHeader
	| reserved |
	bfType _ stream nextLittleEndianNumber: 2.
	bfSize _ stream nextLittleEndianNumber: 4.
	reserved _ stream nextLittleEndianNumber: 4.
	bfOffBits _ stream nextLittleEndianNumber: 4.
	biSize _ stream nextLittleEndianNumber: 4.
	biWidth _ stream nextLittleEndianNumber: 4.
	biHeight _ stream nextLittleEndianNumber: 4.
	biPlanes _ stream nextLittleEndianNumber: 2.
	biBitCount _ stream nextLittleEndianNumber: 2.
	biCompression _ stream nextLittleEndianNumber: 4.
	biSizeImage _ stream nextLittleEndianNumber: 4.
	biXPelsPerMeter _ stream nextLittleEndianNumber: 4.
	biYPelsPerMeter _ stream nextLittleEndianNumber: 4.
	biClrUsed _ stream nextLittleEndianNumber: 4.
	biClrImportant _ stream nextLittleEndianNumber: 4.
! !

!BMPReadWriter methodsFor: 'reading' stamp: 'ar 10/25/2005 13:45'!
readIndexedBmpFile: colors
	"Read uncompressed pixel data of depth d from the given BMP stream, where d is 1, 4, 8, or 16"
	| form bytesPerRow pixelData pixelLine startIndex map bitBlt mask |
	colors 
		ifNil:[form _ Form extent: biWidth@biHeight depth: biBitCount]
		ifNotNil:[form _ ColorForm extent: biWidth@biHeight depth: biBitCount.
				form colors: colors].
	bytesPerRow _ (((biBitCount* biWidth) + 31) // 32) * 4.
	pixelData _ ByteArray new: bytesPerRow * biHeight.
	biHeight to: 1 by: -1 do: [:y |
		pixelLine _ stream next: bytesPerRow.
		startIndex _ ((y - 1) * bytesPerRow) + 1.
		pixelData 
			replaceFrom: startIndex 
			to: startIndex + bytesPerRow - 1 
			with: pixelLine 
			startingAt: 1].
	form bits copyFromByteArray: pixelData.
	biBitCount = 16 ifTrue:[
		map := ColorMap shifts: #(8 -8 0 0) masks: #(16rFF 16rFF00 0 0).
		mask := 16r80008000.
	].
	biBitCount = 32 ifTrue:[
		map := ColorMap shifts: #(24 8 -8 -24) masks: #(16rFF 16rFF00 16rFF0000 16rFF000000).
		mask := 16rFF000000.
	].
	map ifNotNil:[
		bitBlt := BitBlt toForm: form.
		bitBlt sourceForm: form.
		bitBlt colorMap: map.
		bitBlt combinationRule: Form over.
		bitBlt copyBits.
	].
	mask ifNotNil:[
		bitBlt := BitBlt toForm: form.
		bitBlt combinationRule: 7 "bitOr:with:".
		bitBlt halftoneForm: (Bitmap with: mask).
		bitBlt copyBits.
	].
	^ form
! !


!BMPReadWriter methodsFor: 'testing' stamp: 'ar 6/16/2002 15:27'!
understandsImageFormat
	stream size < 54 ifTrue:[^false]. "min size = BITMAPFILEHEADER+BITMAPINFOHEADER"
	self readHeader.
	bfType = 19778 "BM" ifFalse:[^false].
	biSize = 40 ifFalse:[^false].
	biPlanes = 1 ifFalse:[^false].
	bfSize <= stream size ifFalse:[^false].
	biCompression = 0 ifFalse:[^false].
	^true! !


!BMPReadWriter methodsFor: 'writing' stamp: 'yo 2/18/2004 17:57'!
nextPutImage: aForm
	| bhSize rowBytes rgb data colorValues depth image ppw scanLineLen |
	depth := aForm depth.
	[#(1 4 8 32) includes: depth] whileFalse:[depth := depth + 1 asLargerPowerOfTwo].
	image := aForm asFormOfDepth: depth.
	image unhibernate.
	bhSize _ 14.  "# bytes in file header"
	biSize _ 40.  "info header size in bytes"
	biWidth := image width.
	biHeight := image height.
	biClrUsed _ depth = 32 ifTrue: [0] ifFalse:[1 << depth].  "No. color table entries"
	bfOffBits _ biSize + bhSize + (4*biClrUsed).
	rowBytes _ ((depth min: 24) * biWidth + 31 // 32) * 4.
	biSizeImage _ biHeight * rowBytes.

	"Write the file header"
	stream position: 0.
	stream nextLittleEndianNumber: 2 put: 19778.  "bfType = BM"
	stream nextLittleEndianNumber: 4 put: bfOffBits + biSizeImage.  "Entire file size in bytes"
	stream nextLittleEndianNumber: 4 put: 0.  "bfReserved"
	stream nextLittleEndianNumber: 4 put: bfOffBits.  "Offset of bitmap data from start of hdr (and file)"

	"Write the bitmap info header"
	stream position: bhSize.
	stream nextLittleEndianNumber: 4 put: biSize.  "info header size in bytes"
	stream nextLittleEndianNumber: 4 put: image width.  "biWidth"
	stream nextLittleEndianNumber: 4 put: image height.  "biHeight"
	stream nextLittleEndianNumber: 2 put: 1.  "biPlanes"
	stream nextLittleEndianNumber: 2 put: (depth min: 24).  "biBitCount"
	stream nextLittleEndianNumber: 4 put: 0.  "biCompression"
	stream nextLittleEndianNumber: 4 put: biSizeImage.  "size of image section in bytes"
	stream nextLittleEndianNumber: 4 put: 2800.  "biXPelsPerMeter"
	stream nextLittleEndianNumber: 4 put: 2800.  "biYPelsPerMeter"
	stream nextLittleEndianNumber: 4 put: biClrUsed.
	stream nextLittleEndianNumber: 4 put: 0.  "biClrImportant"
	biClrUsed > 0 ifTrue: [
		"write color map; this works for ColorForms, too"
		colorValues _ image colormapIfNeededForDepth: 32.
		1 to: biClrUsed do: [:i |
			rgb _ colorValues at: i.
			0 to: 24 by: 8 do: [:j | stream nextPut: (rgb >> j bitAnd: 16rFF)]]].

	depth < 32 ifTrue: [
		"depth = 1, 4 or 8."
		data _ image bits asByteArray.
		ppw _ 32 // depth.
		scanLineLen _ biWidth + ppw - 1 // ppw * 4.  "# of bytes in line"
		1 to: biHeight do: [:i |
			stream next: scanLineLen putAll: data startingAt: (biHeight-i)*scanLineLen+1.
		].
	] ifFalse: [
		1 to: biHeight do:[:i |
			data _ (image copy: (0@(biHeight-i) extent: biWidth@1)) bits.
			1 to: data size do: [:j | stream nextLittleEndianNumber: 3 put: (data at: j)].
			1 to: (data size*3)+3//4*4-(data size*3) do: [:j | stream nextPut: 0 "pad to 32-bits"]
		].
	].
	stream position = (bfOffBits + biSizeImage) ifFalse: [self error:'Write failure'].
	stream close.! !

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

BMPReadWriter class
	instanceVariableNames: ''!

!BMPReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'!
typicalFileExtensions
	"Answer a collection of file extensions (lowercase) which files that I can read might commonly have"
	^#('bmp')! !


!BMPReadWriter class methodsFor: 'testing' stamp: 'ar 6/16/2002 18:55'!
displayAllFrom: fd
	"BMPReadWriter displayAllFrom: FileDirectory default"
	fd fileNames do:[:fName|
		(fName endsWith: '.bmp') ifTrue:[
			[(Form fromBinaryStream: (fd readOnlyFileNamed: fName)) display.
			Display forceDisplayUpdate] on: Error do:[:nix|].
		].
	].
	fd directoryNames do:[:fdName|
		self displayAllFrom: (fd directoryNamed: fdName)
	].! !

!BMPReadWriter class methodsFor: 'testing' stamp: 'ar 6/16/2002 18:56'!
readAllFrom: fd
	"MessageTally spyOn:[BMPReadWriter readAllFrom: FileDirectory default]"
	fd fileNames do:[:fName|
		(fName endsWith: '.bmp') ifTrue:[
			[Form fromBinaryStream: (fd readOnlyFileNamed: fName)] on: Error do:[:nix].
		].
	].
	fd directoryNames do:[:fdName|
		self readAllFrom: (fd directoryNamed: fdName)
	].! !
TestCase subclass: #BMPReadWriterTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'GraphicsTests-Files'!

!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 02:22'!
bmpData16bit
	"Created via:
		(Base64MimeConverter mimeEncode: 
			(FileStream readOnlyFileNamed: 'bmptest16b.bmp') binary)
				contents
	"
	^(Base64MimeConverter mimeDecodeToBytes:
'Qk24AAAAAAAAADYAAAAoAAAACAAAAAgAAAABABAAAAAAAIIAAADDDgAAww4AAAAAAAAAAAAA
4APgA+AD4AMfAB8AHwAfAOAD4APgA+ADHwAfAB8AHwDgA+AD/3//f/9//38fAB8A4APgA/9/
/3//f/9/HwAfAAAAAAD/f/9//3//fwB8AHwAAAAA/3//f/9//38AfAB8AAAAAAAAAAAAfAB8
AHwAfAAAAAAAAAAAAHwAfAB8AHwAAA==' readStream) contents! !

!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:27'!
bmpData24bit
	"Created via:
		(Base64MimeConverter mimeEncode: 
			(FileStream readOnlyFileNamed: 'bmptest24.bmp') binary)
				contents
	"
	^(Base64MimeConverter mimeDecodeToBytes:
'Qk32AAAAAAAAADYAAAAoAAAACAAAAAgAAAABABgAAAAAAAAAAADEDgAAxA4AAAAAAAAAAAAA
AP8AAP8AAP8AAP8A/wAA/wAA/wAA/wAAAP8AAP8AAP8AAP8A/wAA/wAA/wAA/wAAAP8AAP8A
/////////////////wAA/wAAAP8AAP8A/////////////////wAA/wAAAAAAAAAA////////
////////AAD/AAD/AAAAAAAA////////////////AAD/AAD/AAAAAAAAAAAAAAAAAAD/AAD/
AAD/AAD/AAAAAAAAAAAAAAAAAAD/AAD/AAD/AAD/' readStream) contents! !

!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 02:22'!
bmpData32bit
	"Created via:
		(Base64MimeConverter mimeEncode: 
			(FileStream readOnlyFileNamed: 'bmptest32b.bmp') binary)
				contents
	"
	^(Base64MimeConverter mimeDecodeToBytes:
'Qk04AQAAAAAAADYAAAAoAAAACAAAAAgAAAABACAAAAAAAAIBAADDDgAAww4AAAAAAAAAAAAA
AP8AAAD/AAAA/wAAAP8AAP8AAAD/AAAA/wAAAP8AAAAA/wAAAP8AAAD/AAAA/wAA/wAAAP8A
AAD/AAAA/wAAAAD/AAAA/wAA////AP///wD///8A////AP8AAAD/AAAAAP8AAAD/AAD///8A
////AP///wD///8A/wAAAP8AAAAAAAAAAAAAAP///wD///8A////AP///wAAAP8AAAD/AAAA
AAAAAAAA////AP///wD///8A////AAAA/wAAAP8AAAAAAAAAAAAAAAAAAAAAAAAA/wAAAP8A
AAD/AAAA/wAAAAAAAAAAAAAAAAAAAAAAAAD/AAAA/wAAAP8AAAD/AAAA'
readStream) contents! !

!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:41'!
bmpData4bit
	"Created via:
		(Base64MimeConverter mimeEncode: 
			(FileStream readOnlyFileNamed: 'bmptest4.bmp') binary)
				contents
	"
	^(Base64MimeConverter mimeDecodeToBytes:
'Qk12BAAAAAAAADYEAAAoAAAACAAAAAgAAAABAAgAAAAAAEAAAADEDgAAxA4AAAAAAAAAAAAA
AAAAAAAAgAAAgAAAAICAAIAAAACAAIAAgIAAAMDAwADA3MAA8MqmAAAgQAAAIGAAACCAAAAg
oAAAIMAAACDgAABAAAAAQCAAAEBAAABAYAAAQIAAAECgAABAwAAAQOAAAGAAAABgIAAAYEAA
AGBgAABggAAAYKAAAGDAAABg4AAAgAAAAIAgAACAQAAAgGAAAICAAACAoAAAgMAAAIDgAACg
AAAAoCAAAKBAAACgYAAAoIAAAKCgAACgwAAAoOAAAMAAAADAIAAAwEAAAMBgAADAgAAAwKAA
AMDAAADA4AAA4AAAAOAgAADgQAAA4GAAAOCAAADgoAAA4MAAAODgAEAAAABAACAAQABAAEAA
YABAAIAAQACgAEAAwABAAOAAQCAAAEAgIABAIEAAQCBgAEAggABAIKAAQCDAAEAg4ABAQAAA
QEAgAEBAQABAQGAAQECAAEBAoABAQMAAQEDgAEBgAABAYCAAQGBAAEBgYABAYIAAQGCgAEBg
wABAYOAAQIAAAECAIABAgEAAQIBgAECAgABAgKAAQIDAAECA4ABAoAAAQKAgAECgQABAoGAA
QKCAAECgoABAoMAAQKDgAEDAAABAwCAAQMBAAEDAYABAwIAAQMCgAEDAwABAwOAAQOAAAEDg
IABA4EAAQOBgAEDggABA4KAAQODAAEDg4ACAAAAAgAAgAIAAQACAAGAAgACAAIAAoACAAMAA
gADgAIAgAACAICAAgCBAAIAgYACAIIAAgCCgAIAgwACAIOAAgEAAAIBAIACAQEAAgEBgAIBA
gACAQKAAgEDAAIBA4ACAYAAAgGAgAIBgQACAYGAAgGCAAIBgoACAYMAAgGDgAICAAACAgCAA
gIBAAICAYACAgIAAgICgAICAwACAgOAAgKAAAICgIACAoEAAgKBgAICggACAoKAAgKDAAICg
4ACAwAAAgMAgAIDAQACAwGAAgMCAAIDAoACAwMAAgMDgAIDgAACA4CAAgOBAAIDgYACA4IAA
gOCgAIDgwACA4OAAwAAAAMAAIADAAEAAwABgAMAAgADAAKAAwADAAMAA4ADAIAAAwCAgAMAg
QADAIGAAwCCAAMAgoADAIMAAwCDgAMBAAADAQCAAwEBAAMBAYADAQIAAwECgAMBAwADAQOAA
wGAAAMBgIADAYEAAwGBgAMBggADAYKAAwGDAAMBg4ADAgAAAwIAgAMCAQADAgGAAwICAAMCA
oADAgMAAwIDgAMCgAADAoCAAwKBAAMCgYADAoIAAwKCgAMCgwADAoOAAwMAAAMDAIADAwEAA
wMBgAMDAgADAwKAA8Pv/AKSgoACAgIAAAAD/AAD/AAAA//8A/wAAAP8A/wD//wAA////APr6
+vr8/Pz8+vr6+vz8/Pz6+v/////8/Pr6//////z8AAD/////+fkAAP/////5+QAAAAD5+fn5
AAAAAPn5+fk=' readStream) contents! !

!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:27'!
bmpData8bit
	"Created via:
		(Base64MimeConverter mimeEncode: 
			(FileStream readOnlyFileNamed: 'bmptest8.bmp') binary)
				contents
	"
	^(Base64MimeConverter mimeDecodeToBytes:
'Qk12BAAAAAAAADYEAAAoAAAACAAAAAgAAAABAAgAAAAAAEAAAADEDgAAxA4AAAAAAAAAAAAA
AAAAAAAAgAAAgAAAAICAAIAAAACAAIAAgIAAAMDAwADA3MAA8MqmAAAgQAAAIGAAACCAAAAg
oAAAIMAAACDgAABAAAAAQCAAAEBAAABAYAAAQIAAAECgAABAwAAAQOAAAGAAAABgIAAAYEAA
AGBgAABggAAAYKAAAGDAAABg4AAAgAAAAIAgAACAQAAAgGAAAICAAACAoAAAgMAAAIDgAACg
AAAAoCAAAKBAAACgYAAAoIAAAKCgAACgwAAAoOAAAMAAAADAIAAAwEAAAMBgAADAgAAAwKAA
AMDAAADA4AAA4AAAAOAgAADgQAAA4GAAAOCAAADgoAAA4MAAAODgAEAAAABAACAAQABAAEAA
YABAAIAAQACgAEAAwABAAOAAQCAAAEAgIABAIEAAQCBgAEAggABAIKAAQCDAAEAg4ABAQAAA
QEAgAEBAQABAQGAAQECAAEBAoABAQMAAQEDgAEBgAABAYCAAQGBAAEBgYABAYIAAQGCgAEBg
wABAYOAAQIAAAECAIABAgEAAQIBgAECAgABAgKAAQIDAAECA4ABAoAAAQKAgAECgQABAoGAA
QKCAAECgoABAoMAAQKDgAEDAAABAwCAAQMBAAEDAYABAwIAAQMCgAEDAwABAwOAAQOAAAEDg
IABA4EAAQOBgAEDggABA4KAAQODAAEDg4ACAAAAAgAAgAIAAQACAAGAAgACAAIAAoACAAMAA
gADgAIAgAACAICAAgCBAAIAgYACAIIAAgCCgAIAgwACAIOAAgEAAAIBAIACAQEAAgEBgAIBA
gACAQKAAgEDAAIBA4ACAYAAAgGAgAIBgQACAYGAAgGCAAIBgoACAYMAAgGDgAICAAACAgCAA
gIBAAICAYACAgIAAgICgAICAwACAgOAAgKAAAICgIACAoEAAgKBgAICggACAoKAAgKDAAICg
4ACAwAAAgMAgAIDAQACAwGAAgMCAAIDAoACAwMAAgMDgAIDgAACA4CAAgOBAAIDgYACA4IAA
gOCgAIDgwACA4OAAwAAAAMAAIADAAEAAwABgAMAAgADAAKAAwADAAMAA4ADAIAAAwCAgAMAg
QADAIGAAwCCAAMAgoADAIMAAwCDgAMBAAADAQCAAwEBAAMBAYADAQIAAwECgAMBAwADAQOAA
wGAAAMBgIADAYEAAwGBgAMBggADAYKAAwGDAAMBg4ADAgAAAwIAgAMCAQADAgGAAwICAAMCA
oADAgMAAwIDgAMCgAADAoCAAwKBAAMCgYADAoIAAwKCgAMCgwADAoOAAwMAAAMDAIADAwEAA
wMBgAMDAgADAwKAA8Pv/AKSgoACAgIAAAAD/AAD/AAAA//8A/wAAAP8A/wD//wAA////APr6
+vr8/Pz8+vr6+vz8/Pz6+v/////8/Pr6//////z8AAD/////+fkAAP/////5+QAAAAD5+fn5
AAAAAPn5+fk=' readStream) contents! !

!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:04'!
bmpDataR5G6B5
	"This is a BMP file based on BitmapV4Header which is currently unsupported."
	"Created via:
		(Base64MimeConverter mimeEncode: 
			(FileStream readOnlyFileNamed: 'bmptest16-R5G6B5.bmp') binary)
				contents
	"
	^(Base64MimeConverter mimeDecodeToBytes:
'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA
APgAAOAHAAAfAAAAAAAAAOAH4AfgB+AHHwAfAB8AHwDgB+AH4AfgBx8AHwAfAB8A4AfgB///
////////HwAfAOAH4Af//////////x8AHwAAAAAA//////////8A+AD4AAAAAP//////////
APgA+AAAAAAAAAAAAPgA+AD4APgAAAAAAAAAAAD4APgA+AD4AAA='
readStream) contents! !

!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:04'!
bmpDataX4R4G4B4
	"This is a BMP file based on BitmapV4Header which is currently unsupported."
	"Created via:
		(Base64MimeConverter mimeEncode: 
			(FileStream readOnlyFileNamed: 'bmptest16-X4R4G4B4.bmp') binary)
				contents
	"
	^(Base64MimeConverter mimeDecodeToBytes:
'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA
AA8AAPAAAAAPAAAAAAAAAPAA8ADwAPAADwAPAA8ADwDwAPAA8ADwAA8ADwAPAA8A8ADwAP8P
/w//D/8PDwAPAPAA8AD/D/8P/w//Dw8ADwAAAAAA/w//D/8P/w8ADwAPAAAAAP8P/w//D/8P
AA8ADwAAAAAAAAAAAA8ADwAPAA8AAAAAAAAAAAAPAA8ADwAPAAA='
readStream) contents! !

!BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:05'!
bmpDataX8R8G8B8
	"This is a BMP file based on BitmapV4Header which is currently unsupported."
	"Created via:
		(Base64MimeConverter mimeEncode: 
			(FileStream readOnlyFileNamed: 'bmptest32-X8R8G8B8.bmp') binary)
				contents
	"
	^(Base64MimeConverter mimeDecodeToBytes:
'Qk1IAQAAAAAAAEYAAAA4AAAACAAAAAgAAAABACAAAwAAAAIBAADDDgAAww4AAAAAAAAAAAAA
AAAA/wAA/wAA/wAAAAAAAAAA/wAAAP8AAAD/AAAA/wAA/wAAAP8AAAD/AAAA/wAAAAD/AAAA
/wAAAP8AAAD/AAD/AAAA/wAAAP8AAAD/AAAAAP8AAAD/AAD///8A////AP///wD///8A/wAA
AP8AAAAA/wAAAP8AAP///wD///8A////AP///wD/AAAA/wAAAAAAAAAAAAAA////AP///wD/
//8A////AAAA/wAAAP8AAAAAAAAAAAD///8A////AP///wD///8AAAD/AAAA/wAAAAAAAAAA
AAAAAAAAAAAAAAD/AAAA/wAAAP8AAAD/AAAAAAAAAAAAAAAAAAAAAAAAAP8AAAD/AAAA/wAA
AP8AAA=='
readStream) contents! !


!BMPReadWriterTest methodsFor: 'reading' stamp: 'ar 10/25/2005 13:46'!
testBmp16Bit
	| reader form |
	reader := BMPReadWriter new on: (ReadStream on: self bmpData16bit).
	form := reader nextImage.
	"special black here to compensate for zero-is-transparent effect"
	self assert: (form colorAt: 7@1) = Color red.
	self assert: (form colorAt: 1@7) = Color green.
	self assert: (form colorAt: 7@7) = Color blue.
	self assert: (form colorAt: 4@4) = Color white.
	self assert: (form pixelValueAt: 1@1) = 16r8000.
! !

!BMPReadWriterTest methodsFor: 'reading' stamp: 'ar 10/25/2005 13:46'!
testBmp24Bit
	| reader form |
	reader := BMPReadWriter new on: (ReadStream on: self bmpData24bit).
	form := reader nextImage.
	self assert: (form colorAt: 7@1) = Color red.
	self assert: (form colorAt: 1@7) = Color green.
	self assert: (form colorAt: 7@7) = Color blue.
	self assert: (form colorAt: 4@4) = Color white.
	self assert: (form pixelValueAt: 1@1) = 16rFF000000.
! !

!BMPReadWriterTest methodsFor: 'reading' stamp: 'ar 10/25/2005 13:46'!
testBmp32Bit
	| reader form |
	reader := BMPReadWriter new on: (ReadStream on: self bmpData32bit).
	form := reader nextImage.
	self assert: (form colorAt: 7@1) = Color red.
	self assert: (form colorAt: 1@7) = Color green.
	self assert: (form colorAt: 7@7) = Color blue.
	self assert: (form colorAt: 4@4) = Color white.
	self assert: (form pixelValueAt: 1@1) = 16rFF000000.
! !

!BMPReadWriterTest methodsFor: 'reading' stamp: 'ar 10/24/2005 21:42'!
testBmp4Bit
	| reader form |
	reader := BMPReadWriter new on: (ReadStream on: self bmpData4bit).
	form := reader nextImage.
	self assert: (form colorAt: 1@1) = Color black.
	self assert: (form colorAt: 7@1) = Color red.
	self assert: (form colorAt: 1@7) = Color green.
	self assert: (form colorAt: 7@7) = Color blue.
	self assert: (form colorAt: 4@4) = Color white.
! !

!BMPReadWriterTest methodsFor: 'reading' stamp: 'ar 10/24/2005 21:30'!
testBmp8Bit
	| reader form |
	reader := BMPReadWriter new on: (ReadStream on: self bmpData8bit).
	form := reader nextImage.
	self assert: (form colorAt: 1@1) = Color black.
	self assert: (form colorAt: 7@1) = Color red.
	self assert: (form colorAt: 1@7) = Color green.
	self assert: (form colorAt: 7@7) = Color blue.
	self assert: (form colorAt: 4@4) = Color white.
! !
TransformationMorph subclass: #BOBTransformationMorph
	instanceVariableNames: 'worldBoundsToShow useRegularWarpBlt'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-AdditionalSupport'!

!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 6/4/2001 16:19'!
drawSubmorphsOnREAL: aCanvas 

	| newClip |

	(self innerBounds intersects: aCanvas clipRect) ifFalse: [^self].
	newClip _ ((self innerBounds intersect: aCanvas clipRect) expandBy: 1) truncated.
	useRegularWarpBlt == true ifTrue: [
		transform scale asFloat = 1.0 ifFalse: [
			newClip _ self innerBounds.		"avoids gribblies"
		].
		^aCanvas 
			transformBy: transform
			clippingTo: newClip
			during: [:myCanvas |
				submorphs reverseDo:[:m | myCanvas fullDrawMorph: m]
			]
			smoothing: smoothing
	].
	aCanvas 
		transform2By: transform		"#transformBy: for pure WarpBlt"
		clippingTo: newClip
		during: [:myCanvas |
			submorphs reverseDo:[:m | myCanvas fullDrawMorph: m]
		]
		smoothing: smoothing
! !

!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 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! !


!BOBTransformationMorph methodsFor: 'drawing' stamp: 'RAA 6/4/2001 16:21'!
drawSubmorphsOn: aCanvas

	| t | 
	t _ [
		self drawSubmorphsOnREAL: aCanvas
	] timeToRun.
"Q1 at: 3 put: t."
! !


!BOBTransformationMorph methodsFor: 'geometry' 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: 'layout' stamp: 'dgd 2/21/2003 23:02'!
layoutChanged
	"use the version from Morph"

	| myGuy |
	fullBounds := nil.
	owner ifNotNil: [owner layoutChanged].
	submorphs notEmpty 
		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: 'private' 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]
! !
Morph subclass: #BackgroundMorph
	instanceVariableNames: 'image offset delta running'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-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: 'accessing' stamp: 'fc 7/24/2004 12:23'!
delta
	^delta! !

!BackgroundMorph methodsFor: 'accessing' stamp: 'fc 7/24/2004 12:24'!
delta: aPoint

	delta _ aPoint.! !

!BackgroundMorph methodsFor: 'accessing' stamp: 'fc 7/24/2004 13:50'!
offset
	^offset! !

!BackgroundMorph methodsFor: 'accessing' stamp: 'fc 7/24/2004 13:50'!
offset: aPoint
	offset _ aPoint! !

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

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

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

!BackgroundMorph methodsFor: 'accessing' stamp: 'aoy 2/17/2003 01:20'!
subBounds
	"calculate the submorph bounds"

	| subBounds |
	subBounds := nil.
	self submorphsDo: 
			[:m | 
			subBounds := subBounds isNil
						ifTrue: [m fullBounds]
						ifFalse: [subBounds merge: m fullBounds]].
	^subBounds! !


!BackgroundMorph methodsFor: 'drawing' 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: 'drawing' stamp: 'ar 12/30/2001 19:16'!
fullDrawOn: aCanvas
	(aCanvas isVisible: self fullBounds) ifFalse:[^self].
	running ifFalse: [
		^aCanvas clipBy: (bounds translateBy: aCanvas origin)
				during:[:clippedCanvas| super fullDrawOn: clippedCanvas]].
	(aCanvas isVisible: self bounds) ifTrue:[aCanvas drawMorph: self].
! !


!BackgroundMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:43'!
initialize
	"initialize the state of the receiver"
	super initialize.
""
	offset _ 0 @ 0.
	delta _ 1 @ 0.
	running _ true! !


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

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


!BackgroundMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:56'!
addCustomMenuItems: aCustomMenu hand: aHandMorph 
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	running
		ifTrue: [aCustomMenu add: 'stop' translated action: #stopRunning]
		ifFalse: [aCustomMenu add: 'start' translated action: #startRunning]! !


!BackgroundMorph methodsFor: 'stepping and presenter' stamp: 'fc 7/24/2004 13:47'!
step
	
	running ifTrue: [self slideBy: delta]! !


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

	^ 20! !

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

BackgroundMorph class
	instanceVariableNames: ''!

!BackgroundMorph class methodsFor: 'as yet unclassified' stamp: 'kfr 8/7/2004 16:10'!
test
	"BackgroundMorph test"
	^(BackgroundMorph new addMorph: (ImageMorph new image: Form fromUser))openInWorld.! !
Object subclass: #BadEqualer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Utilities'!
!BadEqualer commentStamp: 'mjr 8/20/2003 13:28' prior: 0!
I am an object that doesn't always report #= correctly.  Used for testing the EqualityTester.!


!BadEqualer methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'!
= other 
	self class = other class
		ifFalse: [^ false].
	^ 100 atRandom < 30 ! !
Object subclass: #BadHasher
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Utilities'!
!BadHasher commentStamp: 'mjr 8/20/2003 13:28' prior: 0!
I am an object that doesn't always hash correctly.  I am used for testing the HashTester.!


!BadHasher methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'!
hash
	"answer with a different hash some of the time"
	100 atRandom < 30
		ifTrue: [^ 1]. 
	^ 2! !
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: 'accessing' stamp: 'md 1/20/2006 15:58'!
valuesAndCounts

	^ contents! !


!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: 'comparing' stamp: 'md 10/17/2004 16:09'!
= aBag
	"Two bags are equal if
	 (a) they are the same 'kind' of thing.
	 (b) they have the same size.
	 (c) each element occurs the same number of times in both of them"

	(aBag isKindOf: Bag) ifFalse: [^false].
	self size = aBag size ifFalse: [^false].
	contents associationsDo: [:assoc|
		(aBag occurrencesOf: assoc key) = assoc value
			ifFalse: [^false]].
	^true

! !


!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: '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 methodsFor: 'private' stamp: 'sma 5/12/2000 14:49'!
setContents: aDictionary
	contents _ aDictionary! !

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

Bag class
	instanceVariableNames: ''!

!Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'!
contentsClass
	^Dictionary! !

!Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 13:31'!
new
	^ self new: 4! !

!Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'!
new: nElements
	^ super new setContents: (self contentsClass 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
"! !
TestCase subclass: #BagTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Unordered'!

!BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:28'!
testAdd
	"self run: #testAdd"
	"self debug: #testAdd"

	| aBag |
	aBag := Bag new.
	aBag add: 'a'.
	aBag add: 'b'.
	
	self assert: aBag size = 2.
	aBag add: 'a'.
	self assert: aBag size = 3.
	self assert: (aBag occurrencesOf: 'a') = 2
	
! !

!BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:28'!
testAddWithOccurrences
	"self debug:#testAddWithOccurrences"
	
	| aBag |
 	aBag := Bag new.	
	aBag add: 'a' withOccurrences: 3.
	self assert: (aBag size = 3).
	
	
	
	
		
! !

!BagTest methodsFor: 'basic tests' stamp: 'TJ 3/8/2006 08:42'!
testAsBag

	| aBag |
 
	aBag := Bag new.	
	
	self assert: aBag asBag = aBag.! !

!BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:29'!
testAsSet

	| aBag aSet |
	aBag := Bag new.	
	aBag add:'a' withOccurrences: 4.
	aBag add:'b' withOccurrences: 2.
	aSet := aBag asSet.
	self assert: aSet size = 2.
	self assert: (aSet occurrencesOf: 'a') = 1 
	! !

!BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:30'!
testCopy
	"self run: #testCopy"
	
	| aBag newBag |
	aBag := Bag new.
	aBag add:'a' withOccurrences: 4.
	aBag add:'b' withOccurrences: 2.
	newBag := aBag copy.
	self assert: newBag = newBag.
	self assert: newBag asSet size = 2.! !

!BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:32'!
testOccurrencesOf
	"self debug: #testOccurrencesOf"

	| aBag |
 	aBag := Bag new.	
	aBag add: 'a' withOccurrences: 3.
	aBag add: 'b'.
	aBag add: 'b'.
	aBag add: 'b'.
	aBag add: 'b'.	
	self assert: (aBag occurrencesOf:'a') = 3.
	self assert: (aBag occurrencesOf:'b') = 4.
	self assert: (aBag occurrencesOf:'c') = 0.
	self assert: (aBag occurrencesOf: nil) =0.
	aBag add: nil.
	self assert: (aBag occurrencesOf: nil) =1.
	! !


!BagTest methodsFor: 'tests' stamp: 'EP 2/28/2006 09:56'!
testCreation
	"self run: #testCreation"
	"self debug: #testCreation"
		
	| bag |
	bag := Bag new.
	self assert: (bag size) = 0.
	self assert: (bag isEmpty).
	
! !

!BagTest methodsFor: 'tests' stamp: 'EP 2/28/2006 10:05'!
testCumulativeCounts
	"self run: #testCumulativeCounts"
	"self debug: #testCumulativeCounts"
		
	| bag cumulativeCounts |
	bag := Bag new.
	bag add: '1' withOccurrences: 50.
	bag add: '2' withOccurrences: 40.
	bag add: '3' withOccurrences: 10.
	
	cumulativeCounts := bag cumulativeCounts.
	
	self assert: cumulativeCounts size = 3.
	self assert: cumulativeCounts first = (50 -> '1').
	self assert: cumulativeCounts second = (90 -> '2').
	self assert: cumulativeCounts third = (100 -> '3').
! !

!BagTest methodsFor: 'tests' stamp: 'EP 3/8/2006 08:39'!
testEqual
	"(self run: #testEqual)"
	"(self debug: #testEqual)"
	| bag1 bag2 |
	bag1 := Bag new.
	bag2 := Bag new.
	self assert: bag1 = bag2.
	bag1 add: #a;
		 add: #b.
	bag2 add: #a;
		 add: #a.
	self deny: bag1 = bag2.
	self assert: bag1 = bag1.
	bag1 add: #a.
	bag2 add: #b.
	self assert: bag1 = bag2.
	bag1 add: #c.
	self deny: bag1 = bag2.
	bag2 add: #c.
	self assert: bag1 = bag2! !

!BagTest methodsFor: 'tests' stamp: 'EP 2/28/2006 09:57'!
testRemove
	"self run: #testRemove"
	"self debug: #testRemove"
	
	| bag item |
	item := 'test item'.
	bag := Bag new.
	
	bag add: item.
	self assert: (bag size) = 1.
	bag remove: item.
	self assert: bag isEmpty.
	
	bag add: item withOccurrences: 2.
	bag remove: item.
	bag remove: item.
	self assert: (bag size) = 0.
	
	self should: [bag remove: item.] raise: Error.! !

!BagTest methodsFor: 'tests' stamp: 'EP 2/28/2006 09:48'!
testSortedCounts
	"self run: #testSortedCounts"
	"self debug: #testSortedCounts"
	
	| bag sortedCounts|
	bag := Bag new.
	bag add: '1' withOccurrences: 10.
	bag add: '2' withOccurrences: 1.
	bag add: '3' withOccurrences: 5.
	
	sortedCounts := bag sortedCounts.
	self assert: sortedCounts size = 3.
	
	self assert: sortedCounts first = (10->'1').
	self assert: sortedCounts second =  (5->'3').
	self assert: sortedCounts third =  (1->'2').	! !

!BagTest methodsFor: 'tests' stamp: 'EP 2/28/2006 09:48'!
testSortedElements
	"self run: #testSortedElements"
	"self debug: #testSortedElements"
	
	| bag sortedElements|
	bag := Bag new.
	bag add: '2' withOccurrences: 1.
	bag add: '1' withOccurrences: 10.
	bag add: '3' withOccurrences: 5.
	
	sortedElements := bag sortedElements.
	
	self assert: sortedElements size = 3.
	
	self assert: sortedElements first = ('1'->10).
	self assert: sortedElements second =  ('2'->1).
	self assert: sortedElements third =  ('3'->5).
	! !
Object subclass: #BalloonBezierSimulation
	instanceVariableNames: 'start end via lastX lastY fwDx fwDy fwDDx fwDDy maxSteps'
	classVariableNames: 'HeightSubdivisions LineConversions MonotonSubdivisions OverflowSubdivisions'
	poolDictionaries: ''
	category: 'Balloon-Simulation'!
!BalloonBezierSimulation commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!


!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 commentStamp: '<historical>' prior: 0!
BalloonBuffer is a repository for primitive data used by the BalloonEngine.!


!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'!
new
	^self new: 256.! !
FormCanvas subclass: #BalloonCanvas
	instanceVariableNames: 'transform colorTransform engine aaLevel deferred'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Balloon'!
!BalloonCanvas commentStamp: '<historical>' prior: 0!
BalloonCanvas is a canvas using the BalloonEngine for drawing wherever possible. It has various methods which other canvases do not support due to the extra features of the balloon engine.!


!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 2/13/2001 21:07'!
ensuredEngine
	engine ifNil:[
		engine _ BalloonEngine new.
		"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: '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: 'converting' stamp: 'ar 11/11/1998 22:57'!
asBalloonCanvas
	^self! !


!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: 'nk 5/1/2004 12:25'!
frameRectangle: r width: w color: c
	"Draw a frame around the given rectangle"
	^self frameAndFillRectangle: r
			fillColor: Color transparent
			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: '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 8/26/2001 22:14'!
drawPolygon: vertices fillStyle: aFillStyle
	"Fill the given polygon."
	self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: nil! !

!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 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: '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: 'TODO' stamp: 'ar 12/31/2001 02:27'!
drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c
	(self ifNoTransformWithIn: boundsRect)
		ifTrue:[^super drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]! !

!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: '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: '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: 'nk 5/1/2004 12:54'!
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: form)
			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."! !
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 commentStamp: '<historical>' prior: 0!
BalloonEngine is the representative for the Balloon engine inside Squeak. For most purposes it should not be used directly but via BalloonCanvas since this ensures proper initialization and is polymorphic with other canvas uses.!


!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: '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 3/6/2001 12:06'!
copyBits
	(bitBlt notNil and:[bitBlt destForm notNil]) ifTrue:[bitBlt destForm unhibernate].
	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: '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: 'bf 4/3/2004 01:36'!
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 asSourceForm.
		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: '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: '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: 'nk 9/26/2003 10:52'!
initialize
	| w |
	w := Display width > 2048 ifTrue: [ 4096 ] ifFalse: [ 2048 ].
	externals := OrderedCollection new: 100.
	span := Bitmap new: w.
	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: '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: '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: '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: '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: '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].
	].! !
SharedPool subclass: #BalloonEngineConstants
	instanceVariableNames: ''
	classVariableNames: 'BEAaLevelIndex BEBalloonEngineSize BEBitBltIndex BEClipRectIndex BEColorTransformIndex BEDeferredIndex BEDestOffsetIndex BEEdgeTransformIndex BEExternalsIndex BEFormsIndex BEPostFlushNeededIndex BESpanIndex BEWorkBufferIndex ETBalloonEdgeDataSize ETIndexIndex ETLinesIndex ETSourceIndex ETXValueIndex ETYValueIndex ETZValueIndex FTBalloonFillDataSize FTDestFormIndex FTIndexIndex FTMaxXIndex FTMinXIndex FTSourceIndex FTYValueIndex GBBaseSize GBBitmapDepth GBBitmapHeight GBBitmapRaster GBBitmapSize GBBitmapWidth GBColormapOffset GBColormapSize GBEndX GBEndY GBFinalX GBMBaseSize GBTileFlag GBUpdateDDX GBUpdateDDY GBUpdateDX GBUpdateDY GBUpdateData GBUpdateX GBUpdateY GBViaX GBViaY GBWideEntry GBWideExit GBWideExtent GBWideFill GBWideSize GBWideUpdateData GBWideWidth GEBaseEdgeSize GEBaseFillSize GEEdgeClipFlag GEEdgeFillsInvalid GEFillIndexLeft GEFillIndexRight GENumLines GEObjectIndex GEObjectLength GEObjectType GEObjectUnused GEPrimitiveBezier GEPrimitiveClippedBitmapFill GEPrimitiveEdge GEPrimitiveEdgeMask GEPrimitiveFill GEPrimitiveFillMask GEPrimitiveLine GEPrimitiveLinearGradientFill GEPrimitiveRadialGradientFill GEPrimitiveRepeatedBitmapFill GEPrimitiveTypeMask GEPrimitiveUnknown GEPrimitiveWide GEPrimitiveWideBezier GEPrimitiveWideEdge GEPrimitiveWideLine GEPrimitiveWideMask GEStateAddingFromGET GEStateBlitBuffer GEStateCompleted GEStateScanningAET GEStateUnlocked GEStateUpdateEdges GEStateWaitingChange GEStateWaitingForEdge GEStateWaitingForFill GEXValue GEYValue GEZValue GErrorAETEntry GErrorBadState GErrorFillEntry GErrorGETEntry GErrorNeedFlush GErrorNoMoreSpace GFDirectionX GFDirectionY GFNormalX GFNormalY GFOriginX GFOriginY GFRampLength GFRampOffset GGBaseSize GLBaseSize GLEndX GLEndY GLError GLErrorAdjDown GLErrorAdjUp GLWideEntry GLWideExit GLWideExtent GLWideFill GLWideSize GLWideWidth GLXDirection GLXIncrement GLYDirection GWAAColorMask GWAAColorShift GWAAHalfPixel GWAALevel GWAAScanMask GWAAShift GWAETStart GWAETUsed GWBezierHeightSubdivisions GWBezierLineConversions GWBezierMonotonSubdivisions GWBezierOverflowSubdivisions GWBufferTop GWClearSpanBuffer GWClipMaxX GWClipMaxY GWClipMinX GWClipMinY GWColorTransform GWCountAddAETEntry GWCountChangeAETEntry GWCountDisplaySpan GWCountFinishTest GWCountInitializing GWCountMergeFill GWCountNextAETEntry GWCountNextFillEntry GWCountNextGETEntry GWCurrentY GWCurrentZ GWDestOffsetX GWDestOffsetY GWEdgeTransform GWFillMaxX GWFillMaxY GWFillMinX GWFillMinY GWFillOffsetX GWFillOffsetY GWGETStart GWGETUsed GWHasClipShapes GWHasColorTransform GWHasEdgeTransform GWHeaderSize GWLastExportedEdge GWLastExportedFill GWLastExportedLeftX GWLastExportedRightX GWMagicIndex GWMagicNumber GWMinimalSize GWNeedsFlush GWObjStart GWObjUsed GWPoint1 GWPoint2 GWPoint3 GWPoint4 GWPointListFirst GWSize GWSpanEnd GWSpanEndAA GWSpanSize GWSpanStart GWState GWStopReason GWTimeAddAETEntry GWTimeChangeAETEntry GWTimeDisplaySpan GWTimeFinishTest GWTimeInitializing GWTimeMergeFill GWTimeNextAETEntry GWTimeNextFillEntry GWTimeNextGETEntry'
	poolDictionaries: ''
	category: 'Balloon-Engine'!

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

BalloonEngineConstants class
	instanceVariableNames: ''!

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:55'!
initEdgeConstants
	"Initialize the edge constants"

	"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"

! !

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'!
initFillConstants
	"Initialize the fill constants"

	"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"
! !

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:59'!
initPrimitiveConstants
	"Initialize the primitive constants"

	"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"

! !

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:00'!
initStateConstants
	"Initialize the state Constants"

	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"
! !

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:04'!
initWorkBufferConstants
	"Initialize the work buffer constants"

	"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"
! !

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'!
initialize
	"BalloonEngineConstants initialize"
	self initStateConstants.
	self initWorkBufferConstants.
	self initPrimitiveConstants.
	self initEdgeConstants.
	self initFillConstants.
	self initializeInstVarNames: BalloonEngine prefixedBy: 'BE'.
	self initializeInstVarNames: BalloonEdgeData prefixedBy: 'ET'.
	self initializeInstVarNames: BalloonFillData prefixedBy: 'FT'.! !

!BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:07'!
initializeInstVarNames: aClass 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.
		(self bindingOf: token) ifNil:[self addClassVarName: token].
		(self bindingOf: token) value: value.
	].
	token := (aString, aClass name,'Size') asSymbol.
	(self bindingOf: token) ifNil:[self addClassVarName: token].
	(self bindingOf: token) value: aClass instSize.! !
Object subclass: #BalloonFillData
	instanceVariableNames: 'index minX maxX yValue source destForm'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Simulation'!
!BalloonFillData commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!


!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! !
TestCase subclass: #BalloonFontTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicTests-Widgets'!

!BalloonFontTest methodsFor: 'tests' stamp: 'sd 12/9/2001 21:44'!
testDefaultFont
	"(self selector: #testDefaultFont) debug"
	self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont.
	self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont.! !

!BalloonFontTest methodsFor: 'tests' stamp: 'sd 12/9/2001 21:55'!
testSpecificFont
	"(self selector: #testSpecificFont) debug"
	| aMorph |
	aMorph := RectangleMorph new.
	self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont.
	self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont.
	aMorph
		balloonFont: (StrikeFont familyName: #ComicPlain size: 19).
	self assert: aMorph balloonFont
			= (StrikeFont familyName: #ComicPlain size: 19).
	"The next test is horrible because I do no know how to access the font 
	with the appropiate interface"
	self assert: (((BalloonMorph getTextMorph: 'lulu' for: aMorph) text runs at: 1)
			at: 1) font
			= (StrikeFont familyName: #ComicPlain size: 19)! !
Object subclass: #BalloonLineSimulation
	instanceVariableNames: 'start end xIncrement xDirection error errorAdjUp errorAdjDown'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Simulation'!
!BalloonLineSimulation commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!


!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: 'accessing' stamp: 'ar 10/3/2000 17:19'!
balloonOwner
	^balloonOwner! !


!BalloonMorph methodsFor: 'initialization' stamp: 'dgd 3/12/2006 14:27'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ self defaultColor muchDarker"Color black"! !

!BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ self class balloonColor! !

!BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:20'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self beSmoothCurve.

	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: 'RAA 7/1/2001 18:48'!
popUpForHand: aHand
	"Pop up the receiver as balloon help for the given hand"
	| worldBounds |

	self lock.
	self fullBounds. "force layout"
	self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber.
	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: 'menus' stamp: 'wiz 12/30/2004 17:14'!
adjustedCenter
	"Return the center of the original textMorph box within the balloon."

	^ (self vertices last: 4) average rounded  ! !


!BalloonMorph methodsFor: 'stepping and presenter' stamp: 'sma 12/23/1999 14:05'!
step
	"Move with target."

	target ifNotNil: [self position: target position + offsetFromTarget].
! !


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


!BalloonMorph methodsFor: 'WiW support' 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: '*MorphicExtras-classification' stamp: 'ar 9/15/2000 17:56'!
isBalloonHelp
	^true! !


!BalloonMorph methodsFor: 'private' stamp: 'sma 12/23/1999 14:06'!
setTarget: aMorph
	(target _ aMorph) ifNotNil: [offsetFromTarget _ self position - target position]! !

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

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: 'sd 12/5/2001 20:27'!
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 for: morph.
	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: '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: 'nk 9/1/2004 10:47'!
chooseBalloonFont
	"BalloonMorph chooseBalloonFont"

	Preferences chooseFontWithPrompt:  'Select the font to be
used for balloon help' translated
		andSendTo: self withSelector: #setBalloonFontTo: highlight: BalloonFont! !

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


!BalloonMorph class methodsFor: 'private' stamp: 'wiz 1/24/2005 00:32'!
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 |
	"wiz 1/8/2005 Choose rect independantly of vertice order or size. Would be nice it this took into account curveBounds but it does not." 
	rect := Rectangle encompassing: vertices.  
	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: 'sd 12/5/2001 20:28'!
getTextMorph: aStringOrMorph for: balloonOwner
	"Construct text morph."
	| m text |
	aStringOrMorph isMorph
		ifTrue: [m _ aStringOrMorph]
		ifFalse: [BalloonFont
				ifNil: [text _ aStringOrMorph]
				ifNotNil: [text _ Text
								string: aStringOrMorph
								attribute: (TextFontReference toFont: balloonOwner balloonFont)].
			m _ (TextMorph new contents: text) centered].
	m setToAdhereToEdge: #adjustedCenter.
	^ m! !

!BalloonMorph class methodsFor: 'private' stamp: 'wiz 1/8/2005 18:05'!
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 // 2 @ 0)
		with: corners first + (0 - bounds width // 4 @ (bounds height // 2))) , corners! !
RectangleMorph subclass: #BalloonRectangleMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Balloon'!
!BalloonRectangleMorph commentStamp: '<historical>' prior: 0!
BalloonRectangleMorph is an example for drawing using the BalloonEngine.!


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


!BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ GradientFillStyle ramp: {0.0 -> Color black. 1.0 -> Color white}! !

!BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 10! !

!BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	| result |
	result _ GradientFillStyle ramp: {0.0 -> Color green. 0.5 -> Color yellow. 1.0 -> Color red}.
	result radial: true.
	^ result! !

!BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:41'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	self extent: 100 @ 100! !


!BalloonRectangleMorph methodsFor: 'rotate scale and flex' stamp: 'ar 11/15/1998 22:20'!
newTransformationMorph
	^MatrixTransformMorph new! !


!BalloonRectangleMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:08'!
canDrawBorder: aBorderStyle
	^aBorderStyle style == #simple! !
Object subclass: #BalloonSolidFillSimulation
	instanceVariableNames: 'color'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Simulation'!
!BalloonSolidFillSimulation commentStamp: '<historical>' prior: 0!
This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.!


!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 commentStamp: '<historical>' prior: 0!
This class is a repository for data which needs to be preserved during certain operations of BalloonCanvas.!


!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: 'ls 2/10/2001 13:26'!
mimeEncode
	"Convert from data to 6 bit characters."

	| phase1 phase2 raw nib lineLength |
	phase1 _ phase2 _ false.
	lineLength := 0.
	[dataStream atEnd] whileFalse: [
		lineLength >= 70 ifTrue: [ mimeStream cr.  lineLength := 0. ].
		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).

		lineLength := lineLength + 4.].
	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 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! !
TestCase subclass: #Base64MimeConverterTest
	instanceVariableNames: 'message'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'CollectionsTests-Streams'!
!Base64MimeConverterTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Base64MimeConverter. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- http://minnow.cc.gatech.edu/squeak/1547
	- the sunit class category!


!Base64MimeConverterTest methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:10'!
setUp
	message := ReadWriteStream on: (String new: 10).
	message nextPutAll: 'Hi There!!'.! !


!Base64MimeConverterTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:23'!
testMimeEncodeDecode

	| encoded |
	encoded := Base64MimeConverter mimeEncode: message.
	self assert: (encoded contents = 'SGkgVGhlcmUh').
     self assert: ((Base64MimeConverter mimeDecodeToChars: encoded) contents = message contents).! !
AbstractSoundSystem subclass: #BaseSoundSystem
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!BaseSoundSystem commentStamp: 'gk 2/24/2004 08:35' prior: 0!
This is the normal sound system in Squeak and is registered in SoundService - an AppRegistry - so that a small highlevel protocol for playing sounds can be used in a pluggable fashion.

More information available in superclass.!


!BaseSoundSystem methodsFor: 'misc' stamp: 'stephaneducasse 2/4/2006 20:40'!
randomBitsFromSoundInput: bitCount
	"Answer a positive integer with the given number of random bits of 'noise' from a sound input source. Typically, one would use a microphone or line input as the sound source, although many sound cards have enough thermal noise that you get random low-order sample bits even with no microphone connected. Only the least signficant bit of the samples is used. Since not all sound cards support 16-bits of sample resolution, we use the lowest bit that changes."
	"(1 to: 10) collect: [:i | BaseSoundSystem new randomBitsFromSoundInput: 512]"

	| recorder buf mid samples bitMask randomBits bit |
	"collect some sound data"
	recorder := SoundRecorder new clearRecordedSound.
	recorder resumeRecording.
	(Delay forSeconds: 1) wait.
	recorder stopRecording.
	buf := recorder condensedSamples.

	"grab bitCount samples from the middle"
	mid := buf monoSampleCount // 2.
	samples := buf copyFrom: mid to: mid + bitCount - 1.

	"find the least significant bit that varies"
	bitMask := 1.
	[bitMask < 16r10000 and:
	 [(samples collect: [:s | s bitAnd: bitMask]) asSet size < 2]]
		whileTrue: [bitMask := bitMask bitShift: 1].
	bitMask = 16r10000 ifTrue: [^ self error: 'sound samples do not vary'].

	"pack the random bits into a positive integer"
	randomBits := 0.
	1 to: samples size do: [:i |
		bit := ((samples at: i) bitAnd: bitMask) = 0 ifTrue: [0] ifFalse: [1].
		randomBits := (randomBits bitShift: 1) + bit].

	^ randomBits	
! !

!BaseSoundSystem methodsFor: 'misc' stamp: 'ads 7/30/2003 22:18'!
sampledSoundChoices
	^ SampledSound soundNames! !

!BaseSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:53'!
shutDown
	SoundPlayer shutDown
! !

!BaseSoundSystem methodsFor: 'misc' stamp: 'ads 7/30/2003 23:17'!
soundNamed: soundName
	^ SampledSound soundNamed: soundName! !


!BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:20'!
beep
	"There is sound support, so we use the default
	sampled sound for a beep."

	Preferences soundsEnabled ifTrue: [
		SampledSound beep]! !

!BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:20'!
playSampledSound: samples rate: rate

	Preferences soundsEnabled ifTrue: [
		(SampledSound samples: samples samplingRate: rate) play]! !

!BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:23'!
playSoundNamed: soundName
	"There is sound support, so we play the given sound."

	Preferences soundsEnabled ifTrue: [
		SampledSound playSoundNamed: soundName asString]! !

!BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:22'!
playSoundNamed: soundName ifAbsentReadFrom: aifFileName

	Preferences soundsEnabled ifTrue: [
		(SampledSound soundNames includes: soundName) ifFalse: [
			(FileDirectory default fileExists: aifFileName) ifTrue: [
				SampledSound
					addLibrarySoundNamed: soundName
					fromAIFFfileNamed: aifFileName]].
		(SampledSound soundNames includes: soundName) ifTrue: [
			SampledSound playSoundNamed: soundName]]! !

!BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:23'!
playSoundNamedOrBeep: soundName
	"There is sound support, so we play the given sound
	instead of beeping."

	Preferences soundsEnabled ifTrue: [
		^self playSoundNamed: soundName]! !

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

BaseSoundSystem class
	instanceVariableNames: ''!

!BaseSoundSystem class methodsFor: 'class initialization' stamp: 'gk 2/23/2004 21:08'!
initialize
	SoundService register: self new.! !

!BaseSoundSystem class methodsFor: 'class initialization' stamp: 'gk 2/23/2004 21:08'!
unload
	SoundService registeredClasses do: [:ss |
		(ss isKindOf: self) ifTrue: [SoundService unregister: ss]].! !
TestCase subclass: #BasicBehaviorClassMetaclassTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Classes'!
!BasicBehaviorClassMetaclassTest commentStamp: '<historical>' prior: 0!
This class contains some tests regarding the classes 
	Behavior
		ClassDescription
			Class
			Metaclass
---
	!


!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:19'!
testBehaviorClassClassDescriptionMetaclassHierarchy
	"self run: #testBehaviorClassClassDescriptionMetaclassHierarchy"
	
	self assert: Class superclass  == ClassDescription.
	self assert: Metaclass superclass == ClassDescription.

	self assert: ClassDescription superclass  == Behavior.
	self assert: Behavior superclass  = Object.

	self assert: Class class class ==  Metaclass.
	self assert: Metaclass class class  == Metaclass.
	self assert: ClassDescription class class == Metaclass.
	self assert: Behavior class class == Metaclass.




	
	
	



	
	

	! !

!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:16'!
testClassDescriptionAllSubInstances
	"self run: #testClassDescriptionAllSubInstances"

	| cdNo clsNo metaclsNo |
	cdNo := ClassDescription allSubInstances size.
	clsNo := Class allSubInstances size .
	metaclsNo := Metaclass allSubInstances size.

	self assert: cdNo = (clsNo + metaclsNo).

	
	
	



	
	

	! !

!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:17'!
testMetaclass
	"self run: #testMetaclass"
	
	self assert: OrderedCollection class class == Metaclass.
	self assert: Dictionary class class == Metaclass.
	self assert: Object class class == Metaclass.




	
	
	



	
	

	! !

!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:12'!
testMetaclassName
	"self run: #testMetaclassName"

	self assert: Dictionary class  name = 'Dictionary class'.
	self assert: OrderedCollection class name = 'OrderedCollection class'.
	! !

!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:12'!
testMetaclassNumberOfInstances
	"self run: #testMetaclassNumberOfInstances"

	self assert: Dictionary class allInstances size  = 1.
	self assert: OrderedCollection class allInstances size  = 1.! !

!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:18'!
testMetaclassPointOfCircularity
	"self run: #testMetaclassPointOfCircularity"

	self assert: Metaclass class instanceCount = 1.
	self assert: Metaclass class someInstance == Metaclass.


	
	
	



	
	

	! !

!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:13'!
testMetaclassSuperclass
	"self run: #testMetaclassSuperclass"

	self assert: Dictionary class superclass == Set class.
	self assert: OrderedCollection class superclass == SequenceableCollection class.

	! !

!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:14'!
testMetaclassSuperclassHierarchy
	"self run: #testMetaclassSuperclassHierarchy"

	| s |
	self assert: SequenceableCollection class instanceCount  = 1.
	self assert: Collection class instanceCount  = 1.
	self assert: Object class instanceCount  = 1.
	self assert: ProtoObject class instanceCount  = 1.
	
	s := OrderedCollection new.
	s add: SequenceableCollection class.
	s add: Collection class.
	s add: Object class.
	s add: ProtoObject class.

	s add: Class.
	s add: ClassDescription.
	s add: Behavior.
	s add: Object.
	s add: ProtoObject.

	self assert: OrderedCollection class allSuperclasses  = s.



	
	

	! !

!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:21'!
testObjectAllSubclasses
	"self run: #testObjectAllSubclasses"

	| n2 |
	n2 := Object allSubclasses size.
	self assert: n2 = (Object allSubclasses
			select: [:cls | cls class class == Metaclass
					or: [cls class == Metaclass]]) size! !

!BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:13'!
testSuperclass
	"self run: #testSuperclass"

	| s |
	self assert: Dictionary superclass == Set.
	self assert: OrderedCollection superclass == SequenceableCollection.

	s := OrderedCollection new.
	s add: SequenceableCollection.
	s add: Collection.
	s add: Object.
	s add: ProtoObject.

	self assert: OrderedCollection allSuperclasses = s.

	
	! !
RectangleMorph subclass: #BasicButton
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!
!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 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 methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color yellow darker! !

!BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 1! !

!BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color yellow! !

!BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:52'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self label: 'Button'; useRoundedCorners! !


!BasicButton methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:56'!
addCustomMenuItems: aCustomMenu hand: aHandMorph 
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'change label...' translated action: #setLabel! !

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

BasicButton class
	instanceVariableNames: ''!

!BasicButton class methodsFor: 'printing' stamp: 'sw 6/16/1998 16:58'!
defaultNameStemForInstances
	^ 'button'! !
Categorizer subclass: #BasicClassOrganizer
	instanceVariableNames: 'subject classComment commentStamp'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:02'!
classComment
	classComment
		ifNil: [^ ''].
	^ classComment text ifNil: ['']! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
classComment: aString 
	"Store the comment, aString, associated with the object that refers to the 
	receiver."

	(aString isKindOf: RemoteString) 
		ifTrue: [classComment _ aString]
		ifFalse: [(aString == nil or: [aString size = 0])
			ifTrue: [classComment _ nil]
			ifFalse: [
				self error: 'use aClass classComment:'.
				classComment _ RemoteString newString: aString onFileNumber: 2]]
				"Later add priorSource and date and initials?"! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
classComment: aString  stamp: aStamp
	"Store the comment, aString, associated with the object that refers to the receiver."

	self commentStamp: aStamp.
	(aString isKindOf: RemoteString) 
		ifTrue: [classComment _ aString]
		ifFalse: [(aString == nil or: [aString size = 0])
			ifTrue: [classComment _ nil]
			ifFalse:
				[self error: 'use aClass classComment:'.
				classComment _ RemoteString newString: aString onFileNumber: 2]]
				"Later add priorSource and date and initials?"! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
commentRemoteStr
	^ classComment! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
commentStamp
	"Answer the comment stamp for the class"

	^ commentStamp! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
commentStamp: aStamp
	commentStamp _ aStamp! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
dateCommentLastSubmitted
	"Answer a Date object indicating when my class comment was last submitted.  If there is no date stamp, or one of the old-time <historical>  guys, return nil"
	"RecentMessageSet organization dateCommentLastSubmitted"

	| aStamp tokens |
	(aStamp _ self commentStamp) isEmptyOrNil ifTrue: [^ nil].
	tokens _ aStamp findBetweenSubStrs: ' 
'.  "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance"
	^ tokens size > 1
		ifTrue:
			[[tokens second asDate] ifError: [nil]]
		ifFalse:
			[nil]! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'!
hasNoComment
	"Answer whether the class classified by the receiver has a comment."

	^classComment == nil! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'!
hasSubject
	^ self subject notNil! !

!BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'!
subject
	^ subject.! !


!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:03'!
fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex
	"Copy the class comment to aFileStream.  If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file."
	| fileComment |
	classComment ifNotNil: 
			[aFileStream cr.
			fileComment _ RemoteString newString: classComment text
							onFileNumber: fileIndex toFile: aFileStream.
			moveSource ifTrue: [classComment _ fileComment]]! !

!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'!
moveChangedCommentToFile: aFileStream numbered: fileIndex 
	"If the comment is in the changes file, then move it to a new file."

	(classComment ~~ nil and: [classComment sourceFileNumber > 1]) ifTrue: 
		[self fileOutCommentOn: aFileStream moveSource: true toFile: fileIndex]! !

!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	self hasSubject ifTrue: [
		(refStrm insideASegment and: [self subject isSystemDefined not]) ifTrue: [
			^ self].	"do trace me"
		(self subject isKindOf: Class) ifTrue: [
			dp _ DiskProxy global: self subject name selector: #organization args: #().
			refStrm replace: self with: dp.
			^ dp]].
	^ self	"in desparation"
! !

!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'!
putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass
	"Store the comment about the class onto file, aFileStream."
	| header |
	classComment ifNotNil:
		[aFileStream cr; nextPut: $!!.
		header _ String streamContents: [:strm | 
				strm nextPutAll: aClass name;
				nextPutAll: ' commentStamp: '.
				commentStamp ifNil: [commentStamp _ '<historical>'].
				commentStamp storeOn: strm.
				strm nextPutAll: ' prior: '; nextPutAll: '0'].
		aFileStream nextChunkPut: header.
		aClass organization fileOutCommentOn: aFileStream
				moveSource: moveSource toFile: sourceIndex.
		aFileStream cr]! !


!BasicClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 16:04'!
setSubject: aClassDescription
	subject _ aClassDescription! !

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

BasicClassOrganizer class
	instanceVariableNames: ''!

!BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'!
class: aClassDescription
	^ self new setSubject: aClassDescription! !

!BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'!
class: aClassDescription defaultList: aSortedCollection
	| inst |
	inst _ self defaultList: aSortedCollection.
	inst setSubject: aClassDescription.
	^ inst! !



!BasicClassOrganizer class methodsFor: 'constants' stamp: 'NS 4/19/2004 15:52'!
ambiguous
	^ #ambiguous! !
Inspector subclass: #BasicInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!

!BasicInspector methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:26'!
inspect: anObject 
	"Initialize the receiver so that it is inspecting anObject. There is no 
	current selection."

	self initialize.
	object := anObject.
	selectionIndex := 0.
	contents := ''! !
Object subclass: #BasicRequestor
	instanceVariableNames: 'caption answer'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Services-Base'!
!BasicRequestor commentStamp: 'rr 7/10/2006 14:44' prior: 0!
This class is the root of the Requestor hierarchy.

Requestors are interfaces between services and the system. ServiceActions are given an instance
of a Requestor, and they ask it for the data they need. The requestor is determined by the model of the application. A class used as a model can implement the #requestor message to return the most suited requestor. A requestor knows how to query its model and the user if needed.

Requestor are defined in hierarchies so that the protocol they rely on (methods starting with 'get') can be easily reused.!


!BasicRequestor methodsFor: 'executing' stamp: 'rr 5/31/2004 22:43'!
get: aString
	self caption: aString.
	^ self getSymbol! !


!BasicRequestor methodsFor: 'generic requests' stamp: 'rr 6/1/2004 21:50'!
caption: aString
	caption := aString! !

!BasicRequestor methodsFor: 'generic requests' stamp: 'rr 10/1/2005 13:13'!
getString
	| result |
	result _ FillInTheBlank  request:caption  initialAnswer:answer contents.
	self newCaption.
	result isEmpty  |result isNil  ifTrue:[ServiceCancelled signal].
	^ result! !

!BasicRequestor methodsFor: 'generic requests' stamp: 'rr 5/31/2004 22:18'!
getStringCollection
	caption := caption, Character cr asString, 'Separate items with space'.
	^ (self getString findTokens: ' ') collect: [:each | each copyWithoutAll: ' ' ]! !

!BasicRequestor methodsFor: 'generic requests' stamp: 'rr 5/31/2004 22:19'!
getSymbol
	^ self getString asSymbol! !

!BasicRequestor methodsFor: 'generic requests' stamp: 'rr 5/31/2004 22:20'!
getSymbolCollection
	^[self getStringCollection collect: [:each | each asSymbol]] 
		on: ServiceCancelled
		do: [#()]! !

!BasicRequestor methodsFor: 'generic requests' stamp: 'rr 10/1/2005 13:13'!
newCaption
	caption _ 'Enter text'.
	answer _ WriteStream  on:''! !


!BasicRequestor methodsFor: 'initialize-release' stamp: 'rr 1/9/2006 12:06'!
initialize
	self newCaption! !
TestCase subclass: #BecomeTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-VM'!

!BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:28'!
testBecome
	"Test the two way become. Note. we cannot use string literals for this test"
	| a b c d |

	a := 'ab' copy.
	b := 'cd' copy.
	c := a.
	d := b.

	a become: b.

	self 
		assert: a = 'cd';
		assert: b = 'ab';
		assert: c = 'cd';
		assert: d = 'ab'.


! !

!BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:28'!
testBecomeForward
	"Test the forward become."
	| a b c d |

	a := 'ab' copy.
	b := 'cd' copy.
	c := a.
	d := b.

	a becomeForward: b.

	self 
		assert: a = 'cd';
		assert: b = 'cd';
		assert: c = 'cd';
		assert: d = 'cd'.


! !

!BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 17:36'!
testBecomeForwardDontCopyIdentityHash
	"Check that
		1. the argument to becomeForward: is NOT modified to have the receiver's identity hash.
		2. the receiver's identity hash is unchanged."

 	| a b hb |

	a := 'ab' copy.
	b := 'cd' copy.
	hb := b identityHash.

	a becomeForward: b copyHash: false.

	self 
		assert: a identityHash = hb;
		assert: b identityHash = hb.

! !

!BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:29'!
testBecomeForwardHash

	| a b c hb |

	a := 'ab' copy.
	b := 'cd' copy.
	c := a.
	hb := b hash.

	a becomeForward: b.

	self 
		assert: a hash = hb;
		assert: b hash = hb;
		assert: c hash = hb.


! !

!BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:27'!
testBecomeForwardIdentityHash
	"Check that
		1. the argument to becomeForward: is modified to have the receiver's identity hash.
		2. the receiver's identity hash is unchanged."

 	| a b ha |

	a := 'ab' copy.
	b := 'cd' copy.
	ha := a identityHash.

	a becomeForward: b.

	self 
		assert: a identityHash = ha;
		assert: b identityHash = ha.

! !

!BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:30'!
testBecomeHash

	| a b c d ha hb |

	a := 'ab' copy.
	b := 'cd' copy.
	c := a.
	d := b.
	ha := a hash.
	hb := b hash.

	a become: b.

	self 
		assert: a hash = hb;
		assert: b hash = ha;
		assert: c hash = hb;
		assert: d hash = ha.


! !

!BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:31'!
testBecomeIdentityHash
	"Note. The identity hash of both objects seems to change after the become:"

	| a b c d |

	a := 'ab' copy.
	b := 'cd' copy.
	c := a.
	d := b.

	a become: b.

	self 
		assert: a identityHash = c identityHash;
		assert: b identityHash = d identityHash;
		deny: a identityHash = b identityHash.
! !
Object subclass: #Beeper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!Beeper commentStamp: 'gk 2/26/2004 22:44' prior: 0!
Beeper provides simple audio (or in some other way) feedback to the user.

The recommended use is "Beeper beep" to give the user the equivalence of a beep. If you want to force the beep to use the primitive in the VM for beeping, then use "Beeper beepPrimitive". In either case, if sounds are disabled there will be no beep.

The actual beeping, when you use "Beeper beep", is done by sending a #play message to a registered playable object. You can register your own playable object by invoking the class side method #setDefault: passing in an object that responds to the #play message.

The default playable object is an instance of Beeper itself which implements #play on the instance side. That implementation delegates the playing of the beep to the default SoundService.

Note that #play is introduced as a common interface between AbstractSound and Beeper.
This way we can register instances of AbstractSound as playable entities, for example:

	Beeper setDefault: (SampledSound new
						setSamples: self coffeeCupClink
						samplingRate: 12000).

Then "Beeper beep" will play the coffeeCup sound.!


!Beeper methodsFor: 'play interface' stamp: 'gk 2/24/2004 23:25'!
play
	"This is how the default Beeper makes a beep,
	by sending beep to the default sound service.
	The sound system will check if sounds are enabled."

	SoundService default beep! !

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

Beeper class
	instanceVariableNames: 'default'!

!Beeper class methodsFor: 'beeping' stamp: 'gk 2/24/2004 08:38'!
beep
	"The preferred way of producing an audible feedback.
	The default playable entity (an instance of Beeper)
	also uses the pluggable SoundService
	mechanism, so it will use the primitive beep only
	if there is no other sound mechanism available."

	self default play
! !

!Beeper class methodsFor: 'beeping' stamp: 'gk 2/24/2004 08:38'!
beepPrimitive
	"Make a primitive beep. Only use this if
	you want to force this to be a primitive beep.
	Otherwise use Beeper class>>beep
	since this method bypasses the current
	registered playable entity."

	Preferences soundsEnabled ifTrue: [
		self primitiveBeep]! !


!Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:51'!
clearDefault
	"Clear the default playable.
	Will be lazily initialized in Beeper class >>default."

	default := nil! !

!Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:55'!
default
	"When the default is not defined it is
	initialized using #newDefault."

	default isNil 
		ifTrue: [default := self newDefault ].
	^ default! !

!Beeper class methodsFor: 'customize' stamp: 'gk 2/24/2004 22:12'!
newDefault
	"Subclasses may override me to provide a default beep.
	This base implementation returns an instance of Beeper
	which uses the pluggable sound service."

	^ self new! !

!Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:54'!
setDefault: aPlayableEntity
	"Set the playable entity used when making a beep.
	The playable entity should implement the message #play."

	default := aPlayableEntity! !


!Beeper class methodsFor: 'private' stamp: 'gk 2/24/2004 23:51'!
primitiveBeep
	"Make a primitive beep. Not to be called directly.
	It is much better to use Beeper class>>beep
	or Beeper class>>beepPrimitive
	since this method bypasses the current
	registered playable entity and does not
	check Preferences class>>soundsEnabled."

	<primitive: 140>
	self primitiveFailed! !
Object subclass: #Behavior
	uses: TPureBehavior @ {#basicAddTraitSelector:withMethod:->#addTraitSelector:withMethod:}
	instanceVariableNames: 'superclass methodDict format'
	classVariableNames: 'ObsoleteSubclasses'
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!Behavior commentStamp: 'al 12/8/2005 20:44' 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: 'accessing' stamp: 'ajh 9/19/2001 17:30'!
classDepth

	superclass ifNil: [^ 1].
	^ superclass classDepth + 1! !

!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/7/2001 17:05'!
methodDict
	methodDict == nil ifTrue: [self recoverFromMDFaultWithTrace].
	^ 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'!
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: 'accessing class hierarchy' stamp: 'nb 5/6/2003 17:11'!
allSubclasses
	"Answer a Set of the receiver's and the receiver's descendent's subclasses. "

	| scan scanTop |
	scan _ OrderedCollection withAll: self subclasses.
	scanTop _ 1.
	[scanTop > scan size]
		whileFalse: [scan addAll: (scan at: scanTop) subclasses.
			scanTop _ scanTop + 1].
	^ scan asSet! !

!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 3/28/2003 15:06'!
allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level 
	"Walk the tree of subclasses, giving the class and its level"
	| subclassNames |
	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 | (self environment 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' stamp: 'sd 3/14/2004 18:09'!
subclasses
	"slow implementation since Behavior does not keep trace of subclasses"
	
	^ self class allInstances  select: [:each | each superclass = self ]! !

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

	^superclass! !

!Behavior methodsFor: 'accessing 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: 'accessing class hierarchy'!
withAllSubclasses
	"Answer a Set of the receiver, the receiver's descendent's, and the  
	receiver's descendent's subclasses."

	^ self allSubclasses add: self;
		 yourself! !


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

	^superclass allClassVarNames! !

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

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

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

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

!Behavior methodsFor: 'accessing instances and variables' stamp: 'ajh 10/17/2002 11:03'!
allowsSubInstVars
	"Classes that allow instances to change classes among its subclasses will want to override this and return false, so inst vars are not accidentally added to its subclasses."

	^ true! !

!Behavior methodsFor: 'accessing instances and variables' stamp: 'tpr 5/30/2003 13:04'!
allSharedPools
	"Answer a Set of the names of the pools (Dictionaries or SharedPool subclasses) 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' stamp: 'sw 5/21/2001 22:51'!
inspectAllInstances 
	"Inpsect all instances of the receiver.  1/26/96 sw"

	| all allSize prefix |
	all _ self allInstances.
	(allSize _ all size) == 0 ifTrue: [^ self inform: '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' stamp: 'sw 5/21/2001 22:51'!
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 inform: 'There are no 
instances of ', self name, '
or any of its subclasses'].
	prefix _ allSize == 1
		ifTrue: 	['The lone instance']
		ifFalse:	['The ', allSize printString, ' instances'].
	
	all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')! !

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

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

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

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

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

	^ OrderedCollection new! !

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

	<primitive: 77>
	^nil! !

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


!Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 12/12/2003 15:57'!
allSelectors
	"Answer all selectors understood by instances of the receiver"

	| coll |
	coll _ OrderedCollection new.
	self withAllSuperclasses do:
		[:aClass | coll addAll: aClass selectors].
	^ coll asIdentitySet! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'al 6/12/2006 10:48'!
basicLocalSelectors
	"Direct accessor for the instance variable localSelectors.
	Because of hardcoded ivar indexes of Behavior and Class in the VM, Class and
	Metaclass declare the needed ivar and override this method as an accessor. 
	By returning nil instead of declaring this method as a subclass responsibility,
	Behavior can be instantiated for creating anonymous classes."
	
	^nil! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'al 3/25/2006 13:17'!
basicLocalSelectors: aSetOrNil
	self subclassResponsibility ! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'mga 3/20/2005 11:11'!
commentsAt:  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."


	^self commentsIn:  (self sourceCodeAt: selector) asString.
	
"Behavior commentsAt: #commentsAt:"! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'mga 3/21/2005 10:53'!
commentsIn: sourceString

	
	| commentStart nextQuotePos someComments aPos |
	('*"*' match: sourceString) ifFalse: [^#()].
	someComments:= OrderedCollection new.
	sourceString size == 0 ifTrue: [^ someComments].
	aPos:=1.
	nextQuotePos:= 0.
	[commentStart _ sourceString findString: '"' startingAt: aPos.
	nextQuotePos:= self nextQuotePosIn: sourceString startingFrom: commentStart.
	(commentStart ~= 0 and: [nextQuotePos >commentStart])] whileTrue: [
		commentStart ~= nextQuotePos ifTrue: [
			someComments add: ((sourceString copyFrom: commentStart + 1 to: nextQuotePos - 1) copyReplaceAll: '""' with: '"').].
	aPos := nextQuotePos+1].
	^someComments! !

!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: 'dvf 9/27/2005 17:08'!
methodDict: aDictionary
	methodDict _ aDictionary! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'mga 3/21/2005 12:04'!
nextQuotePosIn: sourceString startingFrom: commentStart
	| pos nextQuotePos |
	pos _ commentStart + 1.
	[((nextQuotePos _ sourceString findString: '"' startingAt: pos) == (sourceString findString: '""' startingAt: pos)) and: [nextQuotePos ~= 0]]
		whileTrue:
			[pos _ nextQuotePos + 2].
	^nextQuotePos! !

!Behavior methodsFor: 'accessing method dictionary'!
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 nil if none found."
	| aSuper aComment |
	^ (aComment _ self firstPrecodeCommentFor: selector) isEmptyOrNil
		ifTrue: [(self == Behavior
					or: [superclass == nil
							or: [(aSuper _ superclass whichClassIncludesSelector: selector) == nil]])
				ifFalse: [aSuper precodeCommentOrInheritedCommentFor: selector]
			"ActorState precodeCommentOrInheritedCommentFor: #printOn:"]
		ifFalse: [aComment]! !

!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: 'md 1/2/2006 18:56'!
selectorsWithArgs: numberOfArgs
	"Return all selectors defined in this class that take this number of arguments"

	^ self selectors select: [:selector | selector numArgs = numberOfArgs]! !

!Behavior methodsFor: 'accessing method dictionary'!
supermostPrecodeCommentFor: selector 
	"Answer a string representing the precode comment in the most distant 
	superclass's implementation of the selector. Return nil if none found."
	| aSuper superComment |
	(self == Behavior
			or: [superclass == nil
					or: [(aSuper _ superclass whichClassIncludesSelector: selector) == nil]])
		ifFalse: ["There is a super implementor"
			superComment _ aSuper supermostPrecodeCommentFor: selector].
	^ superComment
		ifNil: [self firstPrecodeCommentFor: selector
			"ActorState supermostPrecodeCommentFor: #printOn:"]! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'al 12/6/2004 11:36'!
ultimateSourceCodeAt: selector ifAbsent: aBlock
	"Return the source code at selector, deferring to superclass if necessary"
	^ self sourceCodeAt: selector ifAbsent:
		[superclass
			ifNil:
				[aBlock value]
			 ifNotNil:
				[superclass ultimateSourceCodeAt: selector ifAbsent: aBlock]]! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 11/19/2004 15:18'!
zapAllMethods
	"Remove all methods in this class which is assumed to be obsolete"

	methodDict _ self emptyMethodDictionary.
	self class isMeta ifTrue: [self class zapAllMethods]! !





!Behavior methodsFor: 'enumerating' stamp: 'apb 7/13/2004 00:40'!
allInstancesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the current instances of the 
	receiver.
	
	Because aBlock might change the class of inst (for example, using become:),
	it is essential to compute next before aBlock value: inst."
	| inst next |
	self ==  UndefinedObject ifTrue: [^ aBlock value: nil].
	inst _ self someInstance.
	[inst == nil]
		whileFalse:
		[
		next _ inst nextInstance.
		aBlock value: inst.
		inst _ next]! !

!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: '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'!
allSubclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's subclasses."

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

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

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

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

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

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

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

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

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

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

	aBlock value: self.
	self allSubclassesDo: aBlock! !

!Behavior methodsFor: 'enumerating' stamp: 'nk 2/14/2001 12:09'!
withAllSuperAndSubclassesDoGently: aBlock
	self allSuperclassesDo: aBlock.
	aBlock value: self.
	self allSubclassesDoGently: 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: 'initialize-release' stamp: 'NS 1/28/2004 11:17'!
forgetDoIts
	"get rid of old DoIt methods"
	self 
		basicRemoveSelector: #DoIt;
		basicRemoveSelector: #DoItIn:! !

!Behavior methodsFor: 'initialize-release' stamp: 'kwl 6/22/2006 14:51'!
initialize
	"moved here from the class side's #new"
	self methodDictionary: self emptyMethodDictionary.
	self superclass: Object.
	self setFormat: Object format! !

!Behavior methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 15:07'!
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].
	^ self environment at: obsName asSymbol! !

!Behavior methodsFor: 'initialize-release' stamp: 'al 12/12/2003 20:59'!
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.
	self traitComposition: nil! !


!Behavior methodsFor: 'instance creation' stamp: 'sd 3/28/2003 15:06'!
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"
	self environment signalLowSpace.
	^ self basicNew  "retry if user proceeds"
! !

!Behavior methodsFor: 'instance creation' stamp: 'sd 3/28/2003 15:06'!
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."
		self environment 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: 'Noury Bouraqadi 8/23/2003 14:51'!
new
	"Answer a new initialized instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable."

	^ self basicNew initialize
! !

!Behavior methodsFor: 'instance creation' stamp: 'sd 5/20/2004 11:20'!
new: sizeRequested 
	"Answer an initialized instance of this class with the number of indexable
	variables specified by the argument, sizeRequested."

	^ (self basicNew: sizeRequested) initialize  ! !



!Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:13'!
addObsoleteSubclass: aClass
	"Weakly remember that aClass was a subclass of the receiver and is now obsolete"
	| obs |

	obs _ ObsoleteSubclasses at: self ifAbsent:[WeakArray new].
	(obs includes: aClass) ifTrue:[^self].
	obs _ obs copyWithout: nil.
	obs _ obs copyWith: aClass.
	ObsoleteSubclasses at: self put: obs.
! !

!Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:20'!
obsoleteSubclasses
	"Return all the weakly remembered obsolete subclasses of the receiver"
	| obs |
	obs := ObsoleteSubclasses at: self ifAbsent: [^ #()].
	^ obs copyWithout: nil! !

!Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:21'!
removeAllObsoleteSubclasses
	"Remove all the obsolete subclasses of the receiver"
	ObsoleteSubclasses removeKey: self ifAbsent: [].
! !

!Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:22'!
removeObsoleteSubclass: aClass
	"Remove aClass from the weakly remembered obsolete subclasses"
	| obs |
	obs _ ObsoleteSubclasses at: self ifAbsent:[^ self].
	(obs includes: aClass) ifFalse:[^self].
	obs _ obs copyWithout: aClass.
	obs _ obs copyWithout: nil.
	ObsoleteSubclasses at: self put: obs! !


!Behavior methodsFor: 'printing' stamp: 'md 8/3/2005 00:04'!
formatterClass
	 ^self compilerClass! !

!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' 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'!
printOn: aStream 
	"Refer to the comment in Object|printOn:." 

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


!Behavior methodsFor: 'queries' stamp: 'dvf 9/17/2001 00:18'!
whichClassDefinesClassVar: aString 
	^self whichSuperclassSatisfies: 
			[:aClass | 
			(aClass classVarNames collect: [:each | each asString]) 
				includes: aString asString]! !

!Behavior methodsFor: 'queries' stamp: 'dvf 9/17/2001 00:18'!
whichClassDefinesInstVar: aString 
	^self 
		whichSuperclassSatisfies: [:aClass | aClass instVarNames includes: aString]! !

!Behavior methodsFor: 'queries' stamp: 'bh 3/6/2000 00:51'!
whichSelectorsAssign: instVarName 
	"Answer a Set of selectors whose methods store into the argument, 
	instVarName, as a named instance variable."
	^self whichSelectorsStoreInto: instVarName! !

!Behavior methodsFor: 'queries' stamp: 'bh 3/6/2000 00:52'!
whichSelectorsRead: instVarName 
	"Answer a Set of selectors whose methods access the argument, 
	instVarName, as a named instance variable."
	^self whichSelectorsAccess: instVarName! !

!Behavior methodsFor: 'queries' stamp: 'dvf 9/17/2001 00:18'!
whichSuperclassSatisfies: aBlock 
	(aBlock value: self) ifTrue: [^self].
	^superclass isNil 
		ifTrue: [nil]
		ifFalse: [superclass whichSuperclassSatisfies: aBlock]! !



!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: 'tk 10/26/2001 16:06'!
startUpFrom: anImageSegment
	"Override this when a per-instance startUp message needs to be sent.  For example, to correct the order of 16-bit non-pointer data when it came from a different endian machine."

	^ nil! !

!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 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: 'dvf 9/27/2005 14:57'!
isMeta
	^ false! !

!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: 'sd 3/28/2003 15:07'!
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"

	^(self environment compactClassesArray includes: self)
		or:[(self environment specialObjectsArray includes: self)
			or:[self isKindOf: self]]! !


!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'!
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' stamp: 'al 2/29/2004 14:18'!
bindingOf: varName
	"Answer the binding of some variable resolved in the scope of the receiver"
	^superclass bindingOf: varName! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'sd 5/7/2006 09:58'!
canPerform: selector
	"Answer whether the receiver can safely perform to the message whose selector 
	is the argument: it is not an abstract or cancelled method"

	^ self classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false].! !

!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: 'ar 5/18/2003 18:13'!
classBindingOf: varName
	"Answer the binding of some variable resolved in the scope of the receiver's class"
	^self bindingOf: varName! !

!Behavior methodsFor: 'testing method dictionary'!
whichClassIncludesSelector: aSymbol 
	"Answer the class on the receiver's superclass chain where the 
	argument, aSymbol (a message selector), will be found. Answer nil if none found."
	"Rectangle whichClassIncludesSelector: #inspect."
	(self includesSelector: aSymbol)
		ifTrue: [^ self].
	superclass == nil
		ifTrue: [^ nil].
	^ superclass whichClassIncludesSelector: aSymbol! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'NS 3/30/2004 14:25'!
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: [^IdentitySet 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: 'NS 3/30/2004 14:25'!
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: [^IdentitySet new].
	^ self methodDict keys select: 
		[:sel | (self methodDict at: sel) writesField: instVarIndex]

	"Point whichSelectorsStoreInto: 'x'."! !


!Behavior methodsFor: 'traits' stamp: 'al 9/16/2005 16:04'!
addTraitSelector: aSymbol withMethod: aCompiledMethod
	self basicAddTraitSelector: aSymbol withMethod: aCompiledMethod.
	aCompiledMethod sendsToSuper ifTrue: [
		self recompile: aSymbol]! !

!Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:39'!
hasTraitComposition
	self subclassResponsibility ! !

!Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:36'!
traitComposition
	self subclassResponsibility! !

!Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:39'!
traitComposition: aTraitComposition
	self subclassResponsibility ! !


!Behavior methodsFor: 'user interface' stamp: 'md 8/27/2005 17:18'!
allLocalCallsOn: aSymbol
	"Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy."

	| aSet special byte cls |
	aSet _ Set new.
	cls _ self theNonMetaClass.
	special _ self environment hasSpecialSelector: aSymbol
					ifTrueSetByte: [:b | byte _ b ].
	cls withAllSuperAndSubclassesDoGently: [ :class |
		(class whichSelectorsReferTo: aSymbol special: special byte: byte)
			do: [:sel |
				sel isDoIt ifFalse: [aSet add: class name , ' ', sel]]].
	cls class withAllSuperAndSubclassesDoGently: [ :class |
		(class whichSelectorsReferTo: aSymbol special: special byte: byte)
			do: [:sel |
				sel isDoIt ifFalse: [aSet add: class name , ' ', sel]]].
	^aSet! !

!Behavior methodsFor: 'user interface' stamp: 'md 8/27/2005 17:17'!
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 isDoIt ifFalse: [any _ true]]]].
			any]! !

!Behavior methodsFor: 'user interface' stamp: 'al 11/28/2005 21:58'!
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 isDoIt ifFalse: [any _ true]]].
		any]

"Ob unreferencedInstanceVariables"! !

!Behavior methodsFor: 'user interface' stamp: 'RAA 5/28/2001 12:00'!
withAllSubAndSuperclassesDo: aBlock

	self withAllSubclassesDo: aBlock.
	self allSuperclassesDo: aBlock.
! !


!Behavior methodsFor: '*39Deprecated' stamp: 'md 1/17/2006 17:56'!
scopeHas: varName ifTrue: aBlock
	"Obsolete. Kept around for possible spurios senders which we don't know about"
	self deprecated: 'Obsolete'.
	(self bindingOf: varName) ifNotNilDo:[:binding|
		aBlock value: binding.
		^true].
	^false! !

!Behavior methodsFor: '*39Deprecated' stamp: 'md 2/17/2006 18:48'!
selectorAtMethod: method setClass: classResultBlock 
	"Answer both the message selector associated with the compiled method 
	and the class in which that selector is defined."

	| sel |

	self deprecated: 'please call #methodClass and #selector on the method'.

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


!Behavior methodsFor: '*system-support' stamp: 'tpr 12/17/2003 16:04'!
allCallsOn
	"Answer a SortedCollection of all the methods that refer to me by name or as part of an association in a global dict."


	^ (self  systemNavigation allCallsOn:  (self environment associationAt: self theNonMetaClass name)), (self  systemNavigation allCallsOn:  self theNonMetaClass name)	! !

!Behavior methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:43'!
allCallsOn: aSymbol
	"Answer a SortedCollection of all the methods that call on aSymbol."


	^ self  systemNavigation allCallsOn: aSymbol from: self .
	! !

!Behavior methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:43'!
allUnsentMessages
	"Answer an array of all the messages defined by the receiver that are not sent anywhere in the system."

	^ self environment allUnSentMessagesIn: self selectors! !



!Behavior methodsFor: '*Traits-requires' stamp: 'NS 5/26/2005 12:11'!
classAndMethodFor: aSymbol do: binaryBlock ifAbsent: absentBlock
	"Looks up the selector aSymbol in the class chain. If it is found, binaryBlock is evaluated
	with the class that defines the selector and the associated method. Otherwise
	absentBlock is evaluated."

	| method |
	self withAllSuperclassesDo: [:class |
		method _ class compiledMethodAt: aSymbol ifAbsent: [nil].
		method ifNotNil: [^ binaryBlock value: class value: method].
	].
	^ absentBlock value.! !

!Behavior methodsFor: '*Traits-requires' stamp: 'dvf 9/9/2005 19:45'!
classesComposedWithMe
	^{self}! !

!Behavior methodsFor: '*Traits-requires' stamp: 'NS 5/26/2005 14:27'!
computeSelfSendersFromInheritedSelfSenders: inheritedCollection localSelfSenders: localCollection
	"Compute the set of all self-senders from the set of inherited self-senders and the set of local self-senders."

	| result mDict |
	mDict _ self methodDict.
	result _ IdentitySet new: inheritedCollection size + localCollection size.
	"This if-statement is just a performance optimization. 
	Both branches are semantically equivalent."
	inheritedCollection size > mDict size ifTrue: [
		result addAll: inheritedCollection.
		mDict keysDo: [:each | result remove: each ifAbsent: []].
	] ifFalse: [
		inheritedCollection do: [:each | (mDict includesKey: each) ifFalse: [result add: each]].
	].
	result addAll: localCollection.
	^ result.! !

!Behavior methodsFor: '*Traits-requires' stamp: 'NS 5/26/2005 14:11'!
computeTranslationsAndUpdateUnreachableSet: unreachableCollection
	"This method computes the set of unreachable selectors in the superclass by altering the set of unreachable selectors in this class. In addition, it builds a dictionary mapping super-sent selectors to the selectors of methods sending these selectors."

	| translations reachableSenders oldUnreachable |
	oldUnreachable _ unreachableCollection copy.
	translations _ IdentityDictionary new.
	"Add selectors implemented in this class to unreachable set."
	self methodDict keysDo: [:s | unreachableCollection add: s].
	
	"Fill translation dictionary and remove super-reachable selectors from unreachable."
	self sendCaches superSentSelectorsAndSendersDo: [:sent :senders |
		reachableSenders _ FixedIdentitySet readonlyWithAll: senders notIn: oldUnreachable.
		reachableSenders isEmpty ifFalse: [
			translations at: sent put: reachableSenders.
			unreachableCollection remove: sent ifAbsent: [].
		].
	].
	^ translations! !

!Behavior methodsFor: '*Traits-requires' stamp: 'dvf 8/4/2005 16:48'!
findSelfSendersOf: selector unreachable: unreachableCollection noInheritedSelfSenders: noInheritedBoolean
	"This method answers a subset of all the reachable methods (local or inherited) that self-send selector (empty set => no self-senders).
	See Nathanael Schärli's PhD for more details."
	
	| selfSenders reachableSelfSenders translations |
	"Check whether there are local methods that self-send selector and are reachable."
	selfSenders := self sendCaches selfSendersOf: selector.
	reachableSelfSenders := FixedIdentitySet readonlyWithAll: selfSenders notIn: unreachableCollection.
	(self superclass isNil or: [noInheritedBoolean or: [reachableSelfSenders notEmpty]]) 
		ifTrue: [^ reachableSelfSenders].

	"Compute the set of unreachable superclass methods and super-send translations and recurse."
	translations := self computeTranslationsAndUpdateUnreachableSet: unreachableCollection.
	reachableSelfSenders := superclass findSelfSendersOf: selector unreachable: unreachableCollection noInheritedSelfSenders: false.
	
	"Use the translations to replace selectors that are super-sent with the methods that issue the super-sends."
	reachableSelfSenders := self translateReachableSelfSenders: reachableSelfSenders translations: translations.
	^ reachableSelfSenders.! !

!Behavior methodsFor: '*Traits-requires' stamp: 'dvf 9/12/2005 11:44'!
requiredSelectors
	^RequiredSelectors current for: self! !

!Behavior methodsFor: '*Traits-requires' stamp: 'dvf 9/6/2005 13:14'!
requiredSelectorsCache
	^RequiredSelectors current cacheFor: self! !

!Behavior methodsFor: '*Traits-requires' stamp: 'dvf 9/1/2005 16:36'!
sendCaches
	^LocalSends current for: self! !

!Behavior methodsFor: '*Traits-requires' stamp: 'NS 5/24/2005 16:38'!
translateReachableSelfSenders: senderCollection translations: translationDictionary
	| result superSenders |
	(translationDictionary isEmptyOrNil or: [senderCollection isEmpty]) ifTrue: [^ senderCollection].
	result _ FixedIdentitySet new.
	senderCollection do: [:s |
		superSenders _ translationDictionary at: s ifAbsent: [nil].
		superSenders isNil
			ifTrue: [result add: s]
			ifFalse: [result addAll: superSenders].
		result isFull ifTrue: [^ result].
	].
	^ result.! !

!Behavior methodsFor: '*Traits-requires' stamp: 'dvf 9/12/2005 18:28'!
updateRequiredStatusFor: selector inSubclasses: someClasses
	"Updates the requirements cache to reflect whether selector is required in this class and some of its subclasses."
	| inheritedMethod |
	inheritedMethod := self superclass ifNotNil: [self superclass lookupSelector: selector].
	^self updateRequiredStatusFor: selector  inSubclasses: someClasses parentSelfSenders: FixedIdentitySet new providedInParent: inheritedMethod noInheritedSelfSenders: false accumulatingInto: IdentitySet new.! !

!Behavior methodsFor: '*Traits-requires' stamp: 'dvf 8/9/2005 17:02'!
updateRequiredStatusFor: selector  inSubclasses: someClasses parentSelfSenders: inheritedSelfSenders providedInParent: providedBoolean noInheritedSelfSenders: noInheritedBoolean
	"Updates the requirements cache to reflect whether selector is required in this class and all of its subclasses. The parameter inheritedSelfSenders is a subset of the methods in the parent of this class that are known to self-send selector. providedBoolean indicates whether selector is provided in the parent. noInheritedBoolean is true if no self-senders could be found in the superclass.
	See Nathanael Schärli's PhD for more details."

	| selfSenders provided m |
	"Remove from the inherited selfSenders methods that are potentially unreachable."
	selfSenders := inheritedSelfSenders reject: [:each | self includesSelector: each].
	
	"Check whether the method is provided."
	m := self compiledMethodAt: selector ifAbsent: [nil].
	providedBoolean ifTrue: [
		provided := m isNil or: [m isDisabled not and: [m isExplicitlyRequired not and: [m isSubclassResponsibility not]]].
	] ifFalse: [
		provided := m notNil and: [m isProvided].
	].

	provided ifTrue: [
		"If it is provided, it cannot be required."
		self setRequiredStatusOf: selector to: false.
	] ifFalse: [
		"If there are non-overridden inherited selfSenders we know that it must be
		required. Otherwise, we search for self-senders."
		selfSenders isEmpty ifTrue: [selfSenders := self findSelfSendersOf: selector unreachable: IdentitySet new noInheritedSelfSenders: noInheritedBoolean].
		self setRequiredStatusOf: selector to: selfSenders notEmpty.
	].

	"Do the same for all subclasses."
	self subclassesDo: [:each |
		 (someClasses includes: each) ifTrue: 
			[each updateRequiredStatusFor: selector  
				inSubclasses: someClasses 
				parentSelfSenders: selfSenders 
				providedInParent: provided 
				noInheritedSelfSenders: (provided not and: [selfSenders isEmpty])]].! !

!Behavior methodsFor: '*Traits-requires' stamp: 'dvf 9/12/2005 19:43'!
updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: inheritedSelfSenders providedInParent: inheritedMethod noInheritedSelfSenders: noInheritedBoolean accumulatingInto: requiringClasses 
	"Updates the requirements cache to reflect whether selector is required in this class and all of its subclasses. The parameter inheritedSelfSenders is a subset of the methods in the parent of this class that are known to self-send selector. providedBoolean indicates whether selector is provided in the parent. noInheritedBoolean is true if no self-senders could be found in the superclass.
	See Nathanael Schärli's PhD for more details."

	"Remove from the inherited selfSenders methods that are potentially unreachable."

	| selfSenders m relevantMethod required lookedForInheritedSelfSenders |
	lookedForInheritedSelfSenders := false.
	selfSenders := inheritedSelfSenders 
				reject: [:each | self includesSelector: each].

	"Check whether the method is provided."
	m := self compiledMethodAt: selector ifAbsent: [nil].
	relevantMethod := m ifNotNil: [m] ifNil: [inheritedMethod].
	relevantMethod 
		ifNotNil: [required := relevantMethod isSubclassResponsibility or: [
					relevantMethod isDisabled or: [
						relevantMethod isExplicitlyRequired]]]
		ifNil: ["If there are non-overridden inherited selfSenders we know that it must be
		required. Otherwise, we search for self-senders."

			selfSenders isEmpty 
				ifTrue: 
					[selfSenders := self 
								findSelfSendersOf: selector
								unreachable: IdentitySet new
								noInheritedSelfSenders: noInheritedBoolean.
					lookedForInheritedSelfSenders := true].
			required := selfSenders notEmpty].

	required ifTrue: [requiringClasses add: self].

	"Do the same for all subclasses."
	self subclassesDo: 
			[:each | 
			(someClasses includes: each) 
				ifTrue: 
					[each 
						updateRequiredStatusFor: selector
						inSubclasses: someClasses
						parentSelfSenders: selfSenders
						providedInParent: relevantMethod
						noInheritedSelfSenders: (lookedForInheritedSelfSenders and: [selfSenders isEmpty])
						accumulatingInto: requiringClasses]].
	^requiringClasses! !

!Behavior methodsFor: '*Traits-requires' stamp: 'dvf 8/9/2005 15:39'!
withInheritanceTraitCompositionIncludes: aTrait
	^self withAllSuperclasses anySatisfy: [:c | c traitCompositionIncludes: aTrait]! !


!Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06'!
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 _ self environment 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: 'sd 3/28/2003 15:06'!
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 _ self environment 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' stamp: 'sd 3/28/2003 15:06'!
becomeUncompact
	| cct index |
	cct _ self environment 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: 'sd 11/19/2004 15:13'!
setFormat: aFormatInstanceDescription
	"only use this method with extreme care since it modifies the format of the class 
     ie a description of the number of instance variables and whether the class is
     compact, variable sized"

	format := aFormatInstanceDescription

! !


!Behavior methodsFor: 'as yet unclassified' stamp: 'md 2/16/2006 17:50'!
hash
	^ self name hash! !



!Behavior methodsFor: '*omnibrowser-converting' stamp: 'cwp 4/17/2006 12:16'!
asAnnouncement
	^ self new! !

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

Behavior class
	instanceVariableNames: ''!

!Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:23'!
flushObsoleteSubclasses
	"Behavior flushObsoleteSubclasses"
	ObsoleteSubclasses finalizeValues.! !

!Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:51'!
initialize
	"Behavior initialize"
	"Never called for real"
	ObsoleteSubclasses
		ifNil: [self initializeObsoleteSubclasses]
		ifNotNil: [| newDict | 
			newDict := WeakKeyToCollectionDictionary newFrom: ObsoleteSubclasses.
			newDict rehash.
			ObsoleteSubclasses := newDict]! !

!Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:46'!
initializeObsoleteSubclasses
	ObsoleteSubclasses _ WeakKeyToCollectionDictionary new.! !



!Behavior class methodsFor: 'testing' stamp: 'dvf 9/27/2005 16:12'!
canZapMethodDictionary
	"Return false since zapping the method dictionary of Behavior class or its subclasses will cause the system to fail."
	^false! !
TestCase subclass: #BehaviorTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Classes'!

!BehaviorTest methodsFor: 'tests' stamp: 'sd 3/14/2004 18:11'!
testBehaviorSubclasses
	"self run: #testBehaviorSubclasses"
	
	| b b2 |
	b := Behavior new.
	b superclass: OrderedCollection.
	b methodDictionary: MethodDictionary new.
	self shouldnt: [b subclasses ] raise: Error.
	self shouldnt: [b withAllSubclasses] raise: Error.
	self shouldnt: [b allSubclasses] raise: Error.
	b2 := Behavior new.
	b2 superclass: b.
	b2 methodDictionary: MethodDictionary new.
	self assert: (b subclasses includes: b2).
	self assert: (b withAllSubclasses includes: b).! !

!BehaviorTest methodsFor: 'tests' stamp: 'sd 11/19/2004 15:38'!
testBehaviornewnewShouldNotCrash

	Behavior new new.
	"still not working correctly but at least does not crash the image"
	! !

!BehaviorTest methodsFor: 'tests' stamp: 'ar 9/27/2005 21:43'!
testChange
	"self debug: #testChange"

	| behavior model |
	behavior := Behavior new.
	behavior superclass: Model.
	behavior setFormat: Model format.
	model := Model new.
	model primitiveChangeClassTo: behavior new.
	behavior compile: 'thisIsATest  ^ 2'.
	self assert: model thisIsATest = 2.
	self should: [Model new thisIsATest] raise: MessageNotUnderstood.


! !


!BehaviorTest methodsFor: 'as yet unclassified' stamp: 'md 2/18/2006 16:42'!
testBinding
	self assert: Object binding value = Object.
	self assert: Object binding key = #Object.
	
	self assert: Object class binding value = Object class.
	
	"returns nil for Metaclasses... like Encoder>>#associationFor:"
	
	self assert: Object class binding key = nil.! !
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: 'accessing' stamp: 'ar 11/2/1998 12:14'!
bounds
	"Return the bounds containing the receiver"
	^super bounds encompass: via! !

!Bezier2Segment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'!
degree
	^2! !

!Bezier2Segment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:14'!
via
	"Return the control point"
	^via! !


!Bezier2Segment methodsFor: 'bezier clipping' stamp: 'ar 6/7/2003 23:45'!
bezierClipHeight: dir
	| dirX dirY uMin uMax dx dy u |
	dirX := dir x.
	dirY := dir y.
	uMin := 0.0.
	uMax := (dirX * dirX) + (dirY * dirY).
	dx := via x - start x.
	dy := via y - start y.
	u := (dirX * dx) + (dirY * dy).
	u < uMin ifTrue:[uMin := u].
	u > uMax ifTrue:[uMax := u].
	^uMin@uMax! !


!Bezier2Segment methodsFor: 'converting' stamp: 'ar 6/8/2003 04:19'!
asBezier2Points: error
	^Array with: start with: via with: end! !

!Bezier2Segment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:17'!
asBezier2Segment
	"Represent the receiver as quadratic bezier segment"
	^self! !

!Bezier2Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:05'!
asBezier3Segment
	"Represent the receiver as cubic bezier segment"
	^Bezier3Segment
		from: start
		via: 2*via+start / 3.0
		and: 2*via+end / 3.0
		to: end! !

!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: 'converting' stamp: 'ar 6/7/2003 20:58'!
asTangentSegment
	^LineSegment from: via-start to: end-via! !


!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 6/7/2003 22:37'!
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 * 0.5).! !

!Bezier2Segment methodsFor: 'initialize' stamp: 'ar 6/6/2003 03:03'!
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 := 1.0 / (2 * parameter * (1.0 - parameter)).
	t3 := parameter squared.
	via := (pointOnCurve - (start * t1)  - (end * t3)) * t2! !

!Bezier2Segment methodsFor: 'initialize' stamp: 'ar 6/7/2003 00:09'!
initializeFrom: controlPoints
	controlPoints size = 3 ifFalse:[self error:'Wrong number of control points'].
	start := controlPoints at: 1.
	via := controlPoints at: 2.
	end := controlPoints at: 3.! !


!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 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 6/7/2003 00:08'!
controlPoints
	^{start. via. end}! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:39'!
controlPointsDo: aBlock
	aBlock value: start; value: via; value: end! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:08'!
curveFrom: param1 to: param2
	"Return a new curve from param1 to param2"
	| newStart newEnd newVia tan1 tan2 d1 d2 |
	tan1 := via - start.
	tan2 := end - via.
	param1 <= 0.0 ifTrue:[
		newStart := start.
	] ifFalse:[
		d1 := tan1 * param1 + start.
		d2 := tan2 * param1 + via.
		newStart := (d2 - d1) * param1 + d1
	].
	param2 >= 1.0 ifTrue:[
		newEnd := end.
	] ifFalse:[
		d1 := tan1 * param2 + start.
		d2 := tan2 * param2 + via.
		newEnd := (d2 - d1) * param2 + d1.
	].
	tan2 := (tan2 - tan1 * param1 + tan1) * (param2 - param1).
	newVia := newStart + tan2.
	^self clone from: newStart to: newEnd via: newVia.! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'nk 8/23/2003 12:59'!
end: aPoint
	end := aPoint.! !

!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 6/7/2003 17:21'!
lineSegments: steps do: aBlock
	"Evaluate aBlock with the receiver's line segments"
	"Note: We could use forward differencing here."
	| last deltaStep t next |
	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 6/7/2003 00:04'!
outlineSegment: width
	| delta newStart newEnd param newMid |
	delta := self tangentAtStart normalized * width.
	delta := delta y @ delta x negated.
	newStart := start + delta.
	delta := self tangentAtEnd normalized * width.
	delta := delta y @ delta x negated.
	newEnd := end + delta.
	param := 0.5. "self tangentAtStart r / (self tangentAtStart r + self tangentAtEnd r)."
	delta := (self tangentAt: param) normalized * width.
	delta := delta y @ delta x negated.
	newMid := (self valueAt: param) + delta.
	^self class from: newStart to: newEnd withMidPoint: newMid at: param! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/9/2003 03:43'!
parameterAtExtremeX
	"Note: Only valid for non-monoton receivers"
	^self parameterAtExtreme: 0.0@1.0.
! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/9/2003 03:43'!
parameterAtExtremeY
	"Note: Only valid for non-monoton receivers"
	^self parameterAtExtreme: 1.0@0.0.
! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/9/2003 03:43'!
parameterAtExtreme: tangentDirection
	"Compute the parameter value at which the tangent reaches tangentDirection.
	We need to find the parameter value t at which the following holds

		((t * dir + in) crossProduct: tangentDirection) = 0.

	Since this is pretty ugly we use the normal direction rather than the tangent and compute the equivalent relation using the dot product as

		((t * dir + in) dotProduct: nrm) = 0.

	Reformulation yields

		((t * dir x + in x) * nrm x) + ((t * dir y + in y) * nrm y) = 0.
		(t * dir x * nrm x) + (in x * nrm x) + (t * dir y * nrm y) + (in y * nrm y) = 0.
		(t * dir x * nrm x) + (t * dir y * nrm y) = 0 - ((in x * nrm x) + (in y * nrm y)).

				(in x * nrm x) + (in y * nrm y)
		t = 0 -	---------------------------------------
			 	(dir x * nrm x) + (dir y * nrm y)
	And that's that. Note that we can get rid of the negation by computing 'dir' the other way around (e.g., in the above it would read '-dir') which is trivial to do. Note also that the above does not generalize easily beyond 2D since its not clear how to express the 'normal direction' of a tangent plane.
	"
	| inX inY dirX dirY nrmX nrmY |
	"Compute in"
	inX := via x - start x.
	inY := via y - start y.
	"Compute -dir"
	dirX := inX - (end x - via x).
	dirY := inY - (end y - via y).
	"Compute nrm"
	nrmX := tangentDirection y.
	nrmY := 0 - tangentDirection x.
	"Compute result"
	^((inX * nrmX) + (inY * nrmY)) / 
		((dirX * nrmX) + (dirY * nrmY))! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'nk 12/27/2003 13:00'!
roundTo: quantum
	super roundTo: quantum.
	via := via roundTo: quantum.
! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'nk 8/23/2003 12:59'!
start: aPoint
	start := aPoint.! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:54'!
tangentAtMid
	"Return the tangent at the given parametric value along the receiver"
	| in out |
	in := self tangentAtStart.
	out := self tangentAtEnd.
	^in + out * 0.5! !

!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 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! !


!Bezier2Segment class methodsFor: 'utilities' stamp: 'ar 6/7/2003 18:33'!
makeEllipseSegments: aRectangle
	"Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle.
	This method creates eight bezier segments (two for each quadrant) approximating the oval."
	"EXAMPLE: 
	This example draws an oval with a red border and overlays the approximating bezier segments on top of the oval (drawn in black), thus giving an impression of how closely the bezier resembles the oval. Change the rectangle to see how accurate the approximation is for various radii of the oval.
		| rect |
		rect := 100@100 extent: 1200@500.
		Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red.
		(Bezier2Segment makeEllipseSegments: rect) do:[:seg|
			seg lineSegmentsDo:[:last :next|
				Display getCanvas line: last to: next width: 1 color: Color black]].
	"
	"EXAMPLE: 
		| minRadius maxRadius |
		maxRadius := 300.
		minRadius := 20.
		maxRadius to: minRadius by: -10 do:[:rad|
			| rect |
			rect := 400@400 - rad corner: 400@400 + rad.
			Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red.
			(Bezier2Segment makeEllipseSegments: rect) do:[:seg|
				seg lineSegmentsDo:[:last :next|
					Display getCanvas line: last to: next width: 1 color: Color black]]].
	"
	| nrm topCenter leftCenter rightCenter bottomCenter dir scale seg1a topRight seg1b seg2a bottomRight seg2b center bottomLeft topLeft seg3a seg3b seg4a seg4b |
	dir := aRectangle width * 0.5.
	nrm := aRectangle height * 0.5.

	"Compute the eight control points on the oval"
	scale := 0.7071067811865475. "45 degreesToRadians cos = 45 degreesToRadians sin = 2 sqrt / 2"
	center := aRectangle origin + aRectangle corner * 0.5.

	topCenter := aRectangle topCenter.
	rightCenter := aRectangle rightCenter.
	leftCenter := aRectangle leftCenter.
	bottomCenter := aRectangle bottomCenter.

	topRight := (center x + (dir * scale)) @ (center y - (nrm * scale)).
	bottomRight := (center x + (dir * scale)) @ (center y + (nrm * scale)).
	bottomLeft := (center x - (dir * scale)) @ (center y + (nrm * scale)).
	topLeft := (center x - (dir * scale)) @ (center y - (nrm * scale)).

	scale := 0.414213562373095. "2 sqrt - 1"

	dir := (dir * scale) @ 0.
	nrm := 0 @ (nrm * scale).
	
	seg1a := self from: topCenter via: topCenter + dir to: topRight.
	seg1b := self from: topRight via: rightCenter - nrm to: rightCenter.

	seg2a := self from: rightCenter via: rightCenter + nrm to: bottomRight.
	seg2b := self from: bottomRight via: bottomCenter + dir to: bottomCenter.

	seg3a := self from: bottomCenter via: bottomCenter - dir to: bottomLeft.
	seg3b := self from: bottomLeft via: leftCenter + nrm to: leftCenter.

	seg4a := self from: leftCenter via: leftCenter - nrm to: topLeft.
	seg4b := self from: topLeft via: topCenter - dir to: topCenter.

	^{seg1a. seg1b. seg2a. seg2b. seg3a. seg3b. seg4a. seg4b}! !
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: 'accessing' stamp: 'DSM 10/15/1999 15:20'!
bounds
	^ ((super bounds encompassing: via1) encompassing: via2)! !

!Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'!
degree
	^3! !

!Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/6/2003 21:59'!
length
	"Answer a gross approximation of the length of the receiver"
	^(start dist: via1) + (via1 dist: via2) + (via2 dist: end)! !

!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: 'ar 6/6/2003 22:37'!
via1
	^via1! !

!Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/14/1999 15:31'!
via1: aPoint
	via1 := aPoint! !

!Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/6/2003 22:37'!
via2
	^via2! !

!Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/14/1999 15:31'!
via2: aPoint
	via2 := aPoint! !


!Bezier3Segment methodsFor: 'bezier clipping' stamp: 'ar 6/7/2003 23:45'!
bezierClipHeight: dir
	"Check if the argument overlaps the receiver somewhere 
	along the line from start to end. Optimized for speed."
	| u dirX dirY dx dy uMin uMax |
	dirX := dir x.
	dirY := dir y.
	uMin := 0.0.
	uMax := (dirX * dirX) + (dirY * dirY).

	dx := via1 x - start x.
	dy := via1 y - start y.
	u := (dirX * dx) + (dirY * dy).
	u < uMin ifTrue:[uMin := u].
	u > uMax ifTrue:[uMax := u].

	dx := via2 x - start x.
	dy := via2 y - start y.
	u := (dirX * dx) + (dirY * dy).
	u < uMin ifTrue:[uMin := u].
	u > uMax ifTrue:[uMax := u].

	^uMin@uMax! !


!Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:07'!
asBezier2Points: error
	"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: error.
	pts := Array 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: 'ar 6/7/2003 21:07'!
asBezier2Segments
	"Demote a cubic bezier to a set of approximating quadratic beziers."
	^self asBezier2Segments: 0.5! !

!Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/6/2003 22:23'!
asBezierShape
	"Demote a cubic bezier to a set of approximating quadratic beziers."
	^self asBezierShape: 0.5! !

!Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:09'!
asBezierShape: error
	"Demote a cubic bezier to a set of approximating quadratic beziers.
	Should convert to forward differencing someday"
	^(self asBezier2Points: error) asPointArray.! !

!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: 'ar 6/7/2003 20:58'!
asTangentSegment
	^Bezier2Segment 
		from: via1-start 
		via: via2-via1
		to: end-via2! !

!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: '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: 'initialization' stamp: 'ar 6/7/2003 00:09'!
initializeFrom: controlPoints
	controlPoints size = 4 ifFalse:[self error:'Wrong number of control points'].
	start := controlPoints at: 1.
	via1 := controlPoints at: 2.
	via2 := controlPoints at: 3.
	end := controlPoints at: 4.! !


!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:08'!
controlPoints
	^{start. via1. via2. end}! !

!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:39'!
controlPointsDo: aBlock
	aBlock value: start; value: via1; value: via2; value: end! !

!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/6/2003 21:52'!
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].! !

!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 17:21'!
lineSegments: steps do: aBlock
	"Evaluate aBlock with the receiver's line segments"
	"Note: We could use forward differencing here."
	| last deltaStep t next |
	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].! !

!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:04'!
outlineSegment: width
	| tan1 nrm1 tan2 nrm2 newStart newVia1 newEnd newVia2 dist |
	tan1 := (via1 - start) normalized.
	nrm1 := tan1 * width.
	nrm1 := nrm1 y @ nrm1 x negated.
	tan2 := (end - via2) normalized.
	nrm2 := tan2 * width.
	nrm2 := nrm2 y @ nrm2 x negated.
	newStart := start + nrm1.
	newEnd := end + nrm2.
	dist := (newStart dist: newEnd) * 0.3.
	newVia1 := newStart + (tan1 * dist).
	newVia2 := newEnd - (tan2 * dist).
	^self class from: newStart via: newVia1 and: newVia2 to: newEnd.
! !

!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/6/2003 22:02'!
tangentAtEnd
	^end - via2! !

!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:56'!
tangentAtMid
	| tan1 tan2 tan3 |
	tan1 := via1 - start.
	tan2 := via2 - via1.
	tan3 := end - via2.
	^(tan1 + (2*tan2) + tan3) * 0.25
! !

!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/6/2003 22:01'!
tangentAtStart
	^via1 - start! !

!Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 19:25'!
tangentAt: parameter
	| tan1 tan2 tan3 t1 t2 t3 |
	tan1 := via1 - start.
	tan2 := via2 - via1.
	tan3 := end - via2.
	t1 := (1.0 - parameter) squared.
	t2 := 2 * parameter * (1.0 - parameter).
	t3 := parameter squared.
	^(tan1 * t1) + (tan2 * t2) + (tan3 * t3)! !


!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: '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! !


!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: 'utilities' stamp: 'ar 6/8/2003 03:25'!
makeEllipseSegments: aRectangle
	"Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle.
	This method creates four bezier segments (one for each quadrant) approximating the oval."
	"EXAMPLE: 
	This example draws an oval with a red border and overlays the approximating bezier segments on top of the oval (drawn in black), thus giving an impression of how closely the bezier resembles the oval. Change the rectangle to see how accurate the approximation is for various radii of the oval.
		| rect |
		rect := 100@100 extent: 500@200.
		Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red.
		(Bezier3Segment makeEllipseSegments: rect) do:[:seg|
			seg lineSegmentsDo:[:last :next|
				Display getCanvas line: last to: next width: 1 color: Color black]].
	"
	"EXAMPLE: 
		| minRadius maxRadius |
		maxRadius := 300.
		minRadius := 20.
		maxRadius to: minRadius by: -10 do:[:rad|
			| rect |
			rect := 400@400 - rad corner: 400@400 + rad.
			Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red.
			(Bezier3Segment makeEllipseSegments: rect) do:[:seg|
				seg lineSegmentsDo:[:last :next|
					Display getCanvas line: last to: next width: 1 color: Color black]]].
	"
	^self makeEllipseSegments: aRectangle count: 4! !

!Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:24'!
makeEllipseSegments: aRectangle count: segmentCount
	"Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle.
	This method creates segmentCount bezier segments (one for each quadrant) approximating the oval."
	| count angle seg center scale |
	center := aRectangle origin + aRectangle corner * 0.5.
	scale := aRectangle extent * 0.5.
	count := segmentCount max: 2. "need at least two segments"
	angle := 360.0 / count.
	^(1 to: count) collect:[:i|
		seg := self makeUnitPieSegmentFrom: i-1*angle to: i*angle.
		self controlPoints: (seg controlPoints collect:[:pt| pt * scale + center])
	].! !

!Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:53'!
makePieSegments: aRectangle from: angle1 to: angle2
	"Create a series of cubic bezier segments for the oval inscribed in aRectangle between angle1 and angle2. The segments are oriented clockwise, to get counter-clockwise segments simply switch angle1 and angle2."
	angle2 < angle1 ifTrue:[
		"ccw segments"
		^(self makePieSegments: aRectangle from: angle2 to: angle1) 
			reversed collect:[:seg| seg reversed]
	].
	"Split up segments if larger than 120 degrees"
	angle2 - angle1 > 120 ifTrue:["subdivide"
		| midAngle |
		midAngle := angle1 + angle2 * 0.5.
		^(self makePieSegments: aRectangle from: angle1 to: midAngle),
			(self makePieSegments: aRectangle from: midAngle to: angle2).
	].
	"Create actual pie segment"
	^self makePieSegment: aRectangle from: angle1 to: angle2
! !

!Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:26'!
makePieSegment: aRectangle from: angle1 to: angle2
	"Create a single pie segment for the oval inscribed in aRectangle between angle1 and angle2. If angle1 is less than angle2 this method creates a CW pie segment, otherwise it creates a CCW pie segment."
	| seg center scale |
	angle1 > angle2 ifTrue:["ccw"
		^(self makePieSegment: aRectangle from: angle2 to: angle1) reversed
	].
	"create a unit circle pie segment from angle1 to angle2"
	seg := self makeUnitPieSegmentFrom: angle1 to: angle2.
	"scale the segment to fit aRectangle"
	center := aRectangle origin + aRectangle corner * 0.5.
	scale := aRectangle extent * 0.5.
	^self controlPoints: (seg controlPoints collect:[:pt| pt * scale + center])! !

!Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:59'!
makeUnitPieSegmentFrom: angle1 to: angle2
	"Create a clockwise unit pie segment from angle1 to angle2, that is a pie segment for a circle centered at zero with radius one. Note: This method can be used to create at most a quarter circle."
	| pt1 pt2 rad1 rad2 |
	rad1 := angle1 degreesToRadians.
	rad2 := angle2 degreesToRadians.
	pt1 := rad1 sin @ rad1 cos negated.
	pt2 := rad2 sin @ rad2 cos negated.
	^self makeUnitPieSegmentWith: pt1 and: pt2! !

!Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 04:45'!
makeUnitPieSegmentWith: point1 and: point2
	"Create a clockwise unit pie segment from point1 to point2, that is a pie segment for a circle centered at zero with radius one."
	| pt1 pt2 dir1 dir2 mid length scale cp1 cp2 pt3 magic |
	"point1 and point2 are the points on the unit circle
	for accuracy (or broken input), renormalize them."
	pt1 := point1 normalized.
	pt2 := point2 normalized.
	"compute the normal vectors - those are tangent directions for the bezier"
	dir1 := pt1 y negated @ pt1 x.
	dir2 := pt2 y negated @ pt2 x.
	"Okay, now that we have the points and tangents on the unit circle, let's do the magic. For fitting a cubic bezier onto a circle section we know that we want the end points be on the circle and the tangents to point towards the right direction (both of which we have in the above). What we do NOT know is how to scale the tangents so that midpoint of the bezier is exactly on the circle.
	The good news is that there is a linear relation between the length of the tangent vectors and the distance of the midpoint from the circle's origin. The bad news is that I don't know how to derive it analytically. So what I do here is simply sampling the bezier twice (not really - the first sample is free) and then to compute the distance from the sample."

	"The first sample is just between the two points on the curve"
	mid := pt1 + pt2 * 0.5.

	"The second sample will be taken from the curve with coincident control points at the intersection of dir1 and dir2, which simplifies significantly with a little understanding about trigonometry, since the angle formed between mid, pt1 and the intersection is the same as between the center, pt1 and mid."
	length := mid r.
	"length is not only the distance from the center of the unit circle but also the sine of the angle between the circle's center, pt1 and mid (since center is at zero and pt1 has unit length). Therefore, to scale dir1 to the intersection with dir2 we can use mid's distance from pt1 and simply divide it by the sine value."
	scale := (mid dist: pt1).
	length > 0.0 ifTrue:[ scale := scale / length].
	"now sample the cubic bezier (optimized version for coincident control points)"
	cp1 := pt1 + (dir1 * (scale * 0.75)).
	cp2 := pt2 - (dir2 * (scale * 0.75)).
	pt3 := cp1 + cp2 * 0.5.
	"compute the magic constant"
	scale := (pt3 - mid) r / scale.
	magic := 1.0 - length / scale.
	"and finally answer the pie segment"
	^self
		from: pt1
		via: pt1 + (dir1 * magic)
		and: pt2 - (dir2 * magic)
		to: pt2! !
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 either word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source, or a fully specified ColorMap which may contain a lookup table (ie Bitmap) and/or four separate masks and shifts which are applied to the pixels. For every source pixel, BitBlt will first perform masking and shifting and then index the lookup table, 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 12/30/2001 20:31'!
clipBy: aRectangle
	| aPoint right bottom |
	right _ clipX + clipWidth.
	bottom _ clipY + clipHeight.
	aPoint _ aRectangle origin.
	aPoint x > clipX ifTrue:[clipX _ aPoint x].
	aPoint y > clipY ifTrue:[clipY _ aPoint y].
	aPoint _ aRectangle corner.
	aPoint x < right ifTrue:[right _ aPoint x].
	aPoint y < bottom ifTrue:[bottom _ aPoint y].
	clipWidth _ right - clipX.
	clipHeight _ bottom - clipY.
	clipWidth < 0 ifTrue:[clipWidth _ 0].
	clipHeight < 0 ifTrue:[clipHeight _ 0].! !

!BitBlt methodsFor: 'accessing' stamp: 'ar 12/30/2001 20:33'!
clipByX1: x1 y1: y1 x2: x2 y2: y2
	| right bottom |
	right _ clipX + clipWidth.
	bottom _ clipY + clipHeight.
	x1 > clipX ifTrue:[clipX _ x1].
	y1 > clipY ifTrue:[clipY _ y1].
	x2 < right ifTrue:[right _ x2].
	y2 < bottom ifTrue:[bottom _ y2].
	clipWidth _ right - clipX.
	clipHeight _ bottom - clipY.
	clipWidth < 0 ifTrue:[clipWidth _ 0].
	clipHeight < 0 ifTrue:[clipHeight _ 0].! !

!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' stamp: 'tk 8/15/2001 10:56'!
color
	"Return the current fill color as a Color.  
	 Gives the wrong answer if the halftoneForm is a complex pattern of more than one word."

	halftoneForm ifNil: [^ Color black].
	^ Color colorFromPixelValue: halftoneForm first depth: destForm depth! !

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

!BitBlt methodsFor: 'accessing' stamp: 'ar 5/4/2001 15:45'!
colorMap: map
	"See last part of BitBlt comment. 6/18/96 tk"
	colorMap _ map.! !

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

	combinationRule _ anInteger! !

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

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

	destX _ aPoint x.
	destY _ aPoint y! !

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

	^ destX @ destY extent: width @ height! !

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

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

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

	destX _ anInteger! !

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

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

	destY _ anInteger! !

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

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

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

!BitBlt methodsFor: 'accessing' stamp: 'tbn 9/14/2004 20:38'!
halftoneForm
	"Returns the receivers half tone form. See class commment."
	
	^halftoneForm! !

!BitBlt methodsFor: 'accessing' stamp: 'tbn 9/14/2004 20:39'!
halftoneForm: aBitmap
	"Sets the receivers half tone form. See class commment."
	
	halftoneForm := aBitmap
	
 ! !

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

	height _ anInteger! !

!BitBlt methodsFor: 'accessing'!
sourceForm

	^ sourceForm! !

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

	sourceForm _ aForm! !

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

	sourceX _ aPoint x.
	sourceY _ aPoint y! !

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

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

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

	sourceX _ anInteger! !

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

	sourceY _ anInteger! !

!BitBlt methodsFor: 'accessing' 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: 'ar 5/14/2001 23:32'!
copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule
	"Specify a Color to fill, not a Form. 6/18/96 tk"  
	| destOrigin |
	sourceForm _ srcForm.
	self fillColor: hf.	"sets halftoneForm"
	combinationRule _ rule.
	destOrigin _ destRectangle origin.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourcePt x.
	sourceY _ sourcePt y.
	width _ destRectangle width.
	height _ destRectangle height.
	srcForm == nil ifFalse:
		[colorMap _ srcForm colormapIfNeededFor: destForm].
	^ self copyBits! !

!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: 'yo 3/15/2005 09:54'!
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 isForm) and: [sourceForm unhibernate])
		ifTrue: [^ self copyBits].
	((destForm isForm) and: [destForm unhibernate])
		ifTrue: [^ self copyBits].
	((halftoneForm isForm) and: [halftoneForm unhibernate])
		ifTrue: [^ self copyBits].

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

	"Check if BitBlt doesn't support full color maps"
	(colorMap notNil and:[colorMap isColormap]) ifTrue:[
		colorMap _ colorMap colors.
		^self copyBits].
	"Check if clipping gots us way out of range"
	self clipRange ifTrue:[self roundVariables. ^self copyBitsAgain].

	self error: 'Bad BitBlt arg (Fraction?); proceed to convert.'.
	"Convert all numeric parameters to integers and try again."
	self roundVariables.
	^ self copyBitsAgain! !

!BitBlt methodsFor: 'copying' stamp: 'ar 2/13/2001 21:12'!
copyBitsSimulated
	^Smalltalk at: #BitBltSimulation ifPresent:[:bb| bb copyBitsFrom: self].! !

!BitBlt methodsFor: 'copying' stamp: 'nk 4/17/2004 19:42'!
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 isForm) and: [sourceForm unhibernate])
		ifTrue: [^ self copyBitsTranslucent: factor].
	((destForm isForm) and: [destForm unhibernate])
		ifTrue: [^ self copyBitsTranslucent: factor].
	((halftoneForm isForm) and: [halftoneForm unhibernate])
		ifTrue: [^ self copyBitsTranslucent: factor].

	self primitiveFailed  "Later do nicer error recovery -- share copyBits recovery"! !

!BitBlt methodsFor: 'copying' stamp: 'ar 5/14/2001 23:32'!
copyForm: srcForm to: destPt rule: rule
	^ self copyForm: srcForm to: destPt rule: rule
		colorMap: (srcForm colormapIfNeededFor: destForm)! !

!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: 'ar 5/14/2001 23:32'!
copyFrom: sourceRectangle in: srcForm to: destPt
	| sourceOrigin |
	sourceForm _ srcForm.
	halftoneForm _ nil.
	combinationRule _ 3.  "store"
	destX _ destPt x.
	destY _ destPt y.
	sourceOrigin _ sourceRectangle origin.
	sourceX _ sourceOrigin x.
	sourceY _ sourceOrigin y.
	width _ sourceRectangle width.
	height _ sourceRectangle height.
	colorMap _ srcForm colormapIfNeededFor: destForm.
	self copyBits! !

!BitBlt methodsFor: 'copying' stamp: 'yo 5/20/2004 14:30'!
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.
	^ destX@destY.
! !

!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' stamp: 'ar 3/1/2004 13:49'!
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 unhibernate. "before poking"
	destForm bits at: 1 put: 0.  "Just to be sure"
	self copyBits.
	^ destForm bits at: 1! !

!BitBlt methodsFor: 'copying' stamp: 'ar 3/1/2004 13:49'!
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 unhibernate. "before poking"
	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: 'text display' stamp: 'ar 10/24/2005 21:49'!
displayString: aString from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY font: aFont
	"Double dispatch into the font. This method is present so that other-than-bitblt entities can be used by CharacterScanner and friends to display text."
	^ aFont displayString: aString on: self from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY! !

!BitBlt methodsFor: 'text display' stamp: 'ar 10/25/2005 01:12'!
displayString: aString from: startIndex to: stopIndex at: aPoint kern: kernDelta font: aFont
	"Double dispatch into the font. This method is present so that other-than-bitblt entities can be used by CharacterScanner and friends to display text."
	^ aFont displayString: aString on: self from: startIndex to: stopIndex at: aPoint kern: kernDelta! !

!BitBlt methodsFor: 'text display' stamp: 'ar 10/24/2005 21:48'!
installFont: aFont foregroundColor: foregroundColor backgroundColor: backgroundColor
	"Double dispatch into the font. This method is present so that other-than-bitblt entities can be used by CharacterScanner and friends to display text."
	^aFont installOn: self foregroundColor: foregroundColor backgroundColor: backgroundColor! !


!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 3/8/2003 00:34'!
clipRange
	"clip and adjust source origin and extent appropriately"
	"first in x"
	| sx sy dx dy bbW bbH |
	"fill in the lazy state if needed"
	destX ifNil:[destX := 0].
	destY ifNil:[destY := 0].
	width ifNil:[width := destForm width].
	height ifNil:[height := destForm height].
	sourceX ifNil:[sourceX := 0].
	sourceY ifNil:[sourceY := 0].
	clipX ifNil:[clipX := 0].
	clipY ifNil:[clipY := 0].
	clipWidth ifNil:[clipWidth := destForm width].
	clipHeight ifNil:[clipHeight := destForm height].

	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))].
	sourceForm ifNotNil:[
		sx < 0
			ifTrue: [dx _ dx - sx.
					bbW _ bbW + sx.
					sx _ 0].
		sx + bbW > sourceForm width
			ifTrue: [bbW _ bbW - (sx + bbW - sourceForm width)].
		sy < 0
			ifTrue: [dy _ dy - sy.
					bbH _ bbH + sy.
					sy _ 0].
		sy + bbH > sourceForm height
			ifTrue: [bbH _ bbH - (sy + bbH - sourceForm height)].
	].
	(bbW <= 0 or:[bbH <= 0]) ifTrue:[
		sourceX := sourceY := destX := destY := clipX := clipY := width := height := 0.
		^true].
	(sx = sourceX 
		and:[sy = sourceY 
		and:[dx = destX 
		and:[dy = destY 
		and:[bbW = width 
		and:[bbH = height]]]]]) ifTrue:[^false].
	sourceX := sx.
	sourceY := sy.
	destX := dx.
	destY := dy.
	width := bbW.
	height := bbH.
	^true! !

!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: 'ar 5/14/2001 23:43'!
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: (destForm pixelValueFor: backgroundColor)].
	sourceForm depth = 1 ifTrue:
		[colorMap at: 2 put: (destForm pixelValueFor: foregroundColor).
		"Ignore any halftone pattern since we use a color map approach here"
		halftoneForm _ nil].
	sourceY _ 0.
	height _ aStrikeFont height.
! !

!BitBlt methodsFor: 'private' stamp: 'yo 1/8/2005 09:12'!
installTTCFont: aTTCFont foregroundColor: foregroundColor backgroundColor: backgroundColor
	"Set up the parameters.  Since the glyphs in a TTCFont is 32bit depth form, it tries to use rule=34 to get better AA result if possible."

	((aTTCFont depth = 32)) ifTrue: [
		destForm depth <= 8 ifTrue: [
			self colorMap: (self cachedFontColormapFrom: aTTCFont depth to: destForm depth).
			self combinationRule: Form paint.
		] ifFalse: [
			self colorMap: nil.
			self combinationRule: 34.
		].
		halftoneForm _ nil.
		sourceY _ 0.
		height _ aTTCFont 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: 'yo 3/11/2005 14:49'!
primDisplayString: aString from: startIndex to: stopIndex map: glyphMap xTable: xTable kern: kernDelta
	| ascii |
	<primitive:'primitiveDisplayString' module:'BitBltPlugin'>
	startIndex to: stopIndex do:[:charIndex|
		ascii _ (aString at: charIndex) asciiValue.
		sourceX _ xTable at: ascii + 1.
		width _ (xTable at: ascii + 2) - sourceX.
		self copyBits.
		destX _ destX + width + kernDelta.
	].! !

!BitBlt methodsFor: 'private' stamp: 'yo 3/15/2005 09:47'!
roundVariables

	| maxVal minVal |
	maxVal _ SmallInteger maxVal.
	minVal _ SmallInteger minVal.
	destX _ destX asInteger min: maxVal max: minVal.
	destY _ destY asInteger min: maxVal max: minVal.
	width _ width asInteger min: maxVal max: minVal.
	height _ height asInteger min: maxVal max: minVal.
	sourceX _ sourceX asInteger min: maxVal max: minVal.
	sourceY _ sourceY asInteger min: maxVal max: minVal.
	clipX _ clipX asInteger min: maxVal max: minVal.
	clipY _ clipY asInteger min: maxVal max: minVal.
	clipWidth _ clipWidth asInteger min: maxVal max: minVal.
	clipHeight _ clipHeight asInteger min: maxVal max: minVal.
! !

!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: 'ar 5/14/2001 23:32'!
setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect

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

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

BitBlt class
	instanceVariableNames: ''!

!BitBlt class methodsFor: 'benchmarks' stamp: 'ar 4/24/2001 23:49'!
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.01.
				Transcript show: improvement printString; tab; tab.
				log print: improvement; tab; tab].
		] ifFalse:[
			Transcript cr; show: oldLine.
			log cr; nextPutAll: oldLine.
		].
	].
	^log contents! !

!BitBlt class methodsFor: 'benchmarks' stamp: 'ar 5/14/2001 23:31'!
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 colormapIfNeededFor: dest).
				bb combinationRule: rule.

				"Measure speed of copyBits"
				t _ Time millisecondsToRun:[bb copyBits].
				Transcript tab; show: t printString.
				log tab; nextPutAll: t printString.

				bb sourceForm: source destRect: source boundingBox.

				"Measure speed of 1x1 warpBits"
				bb cellSize: 1.
				t _ Time millisecondsToRun:[bb warpBits].
				Transcript tab; show: t printString.
				log tab; nextPutAll: t printString.

				"Measure speed of 2x2 warpBits"
				bb cellSize: 2.
				t _ Time millisecondsToRun:[bb warpBits].
				Transcript tab; show: t printString.
				log tab; nextPutAll: t printString.

				"Measure speed of 3x3 warpBits"
				bb cellSize: 3.
				t _ Time millisecondsToRun:[bb warpBits].
				Transcript tab; show: t printString.
				log tab; nextPutAll: t printString.
			].
		].
	].
	^log contents! !

!BitBlt class methodsFor: 'benchmarks' stamp: 'ar 5/14/2001 23:31'!
benchmark2		"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 colormapIfNeededFor: dest).
				bb combinationRule: rule.

				"Measure speed of copyBits"
				t _ Time millisecondsToRun:[1 to: 10 do:[:i| 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:[1 to: 4 do:[:i| 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! !

!BitBlt class methodsFor: 'benchmarks' stamp: 'ar 4/26/2001 21:04'!
benchmark3		"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 colormapIfNeededFor: dest).
				bb combinationRule: rule.

				"Measure speed of copyBits"
				t _ Time millisecondsToRun:[1 to: 10 do:[:i| 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:[1 to: 4 do:[:i| 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! !


!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' stamp: 'ar 5/4/2001 16:02'!
exampleColorMap	"BitBlt exampleColorMap"
	"This example shows what one can do with the fixed part of a color map. The color map, as setup below, rotates the bits of a pixel all the way around. Thus you'll get a (sometime strange looking ;-) animation of colors which will end up exactly the way it looked at the beginning. The example is given to make you understand that the masks and shifts can be used for a lot more than simply color converting pixels. In this example, for instance, we use only two of the four independent shifters."
	| cc bb |
	cc _ ColorMap masks: {
		1 << (Display depth-1). "mask out high bit of color component"
		1 << (Display depth-1) - 1. "mask all other bits"
		0.
		0}
		shifts: {
			1 - Display depth. "shift right to bottom most position"
			1. "shift all other pixels one bit left"
			0.
			0}.
	bb _ BitBlt toForm: Display.
	bb 
		sourceForm: Display;
		combinationRule: 3;
		colorMap: cc.
	1 to: Display depth do:[:i|
		bb copyBits.
		Display forceDisplayUpdate.
	].
! !

!BitBlt class methodsFor: 'examples' stamp: 'dew 9/18/2001 02:30'!
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). This only works at Display depth of 1. (Rule 15 does not work?)"
	| path displayDepth |

	displayDepth _ Display depth.
	Display newDepth: 1.

	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: nil].

	[Sensor anyButtonPressed] whileFalse: [].
	Display newDepth: displayDepth.

	"BitBlt exampleOne"! !

!BitBlt class methodsFor: 'examples' stamp: 'jrm 2/21/2001 23:43'!
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. This only works at Depth of 1."
	| f aBitBlt displayDepth |
	"create a small black Form source as a brush. "
	displayDepth _ Display depth.
	Display newDepth: 1.
	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 over
		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].
	Display newDepth: displayDepth.
	"BitBlt exampleTwo"! !


!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: 'private' stamp: 'jrm 2/21/2001 23:45'!
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. Only works with Display depth of 1"

	| 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: 0 fillColor: nil"  ! !
TestCase subclass: #BitBltClipBugs
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Bugs'!

!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'!
testDrawingWayOutside
	| f1 bb f2 |
	f1 := Form extent: 100@100 depth: 1.
	f2 := Form extent: 100@100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb sourceForm: f2.
	bb destOrigin: SmallInteger maxVal squared asPoint.
	bb width: 100; height: 100.
	self shouldnt:[bb copyBits] raise: Error.
! !

!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'!
testDrawingWayOutside2
	| f1 bb f2 |
	f1 := Form extent: 100@100 depth: 1.
	f2 := Form extent: 100@100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb sourceForm: f2.
	bb destOrigin: 0@0.
	bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared.
	self shouldnt:[bb copyBits] raise: Error.! !

!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'!
testDrawingWayOutside3
	| f1 bb f2 |
	f1 := Form extent: 100@100 depth: 1.
	f2 := Form extent: 100@100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb sourceForm: f2.
	bb destOrigin: SmallInteger maxVal squared asPoint.
	bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared.
	self shouldnt:[bb copyBits] raise: Error.
! !

!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'!
testDrawingWayOutside4
	| f1 bb f2 |
	f1 := Form extent: 100@100 depth: 1.
	f2 := Form extent: 100@100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb sourceForm: f2.
	bb destOrigin: SmallInteger maxVal squared asPoint.
	bb width: 100; height: 100.
	bb sourceOrigin: SmallInteger maxVal squared asPoint.
	self shouldnt:[bb copyBits] raise: Error.
! !

!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'!
testDrawingWayOutside5
	| f1 bb f2 |
	f1 := Form extent: 100@100 depth: 1.
	f2 := Form extent: 100@100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb sourceForm: f2.
	bb destOrigin: 0@0.
	bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared.
	bb sourceOrigin: SmallInteger maxVal squared asPoint.
	self shouldnt:[bb copyBits] raise: Error.! !

!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'!
testDrawingWayOutside6
	| f1 bb f2 |
	f1 := Form extent: 100@100 depth: 1.
	f2 := Form extent: 100@100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb sourceForm: f2.
	bb destOrigin: SmallInteger maxVal squared asPoint.
	bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared.
	bb sourceOrigin: SmallInteger maxVal squared asPoint.
	self shouldnt:[bb copyBits] raise: Error.
! !

!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'!
testFillingWayOutside
	| f1 bb |
	f1 := Form extent: 100@100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb fillColor: Color black.
	bb destOrigin: SmallInteger maxVal squared asPoint.
	bb width: 100; height: 100.
	self shouldnt:[bb copyBits] raise: Error.
! !

!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'!
testFillingWayOutside2
	| f1 bb |
	f1 := Form extent: 100@100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb fillColor: Color black.
	bb destOrigin: 0@0.
	bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared.
	self shouldnt:[bb copyBits] raise: Error.! !

!BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'!
testFillingWayOutside3
	| f1 bb |
	f1 := Form extent: 100@100 depth: 1.
	bb := BitBlt toForm: f1.
	bb combinationRule: 3.
	bb fillColor: Color black.
	bb destOrigin: SmallInteger maxVal squared asPoint.
	bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared.
	self shouldnt:[bb copyBits] raise: Error.
! !
ClassTestCase subclass: #BitBltTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'GraphicsTests-Primitives'!

!BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:12'!
testAlphaCompositing
	"self run: #testAlphaCompositing"

	| bb f1 f2 mixColor result eps |
	f1 := Form extent: 1@1 depth: 32.
	f2 := Form extent: 1@1 depth: 32.
	eps := 0.5 / 255.
	0 to: 255 do:[:i|
		f1 colorAt: 0@0 put: Color blue.
		mixColor := Color red alpha: i / 255.0.
		f2 colorAt: 0@0 put: mixColor.
		mixColor := f2 colorAt: 0@0.
		bb := BitBlt toForm: f1.
		bb sourceForm: f2.
		bb combinationRule: Form blend.
		bb copyBits.
		result := f1 colorAt: 0@0.
		self assert: (result red - mixColor alpha) abs < eps.
		self assert: (result blue - (1.0 - mixColor alpha)) abs < eps.
		self assert: result alpha = 1.0.
	].! !

!BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:12'!
testAlphaCompositing2
	"self run: #testAlphaCompositing2"

	| bb f1 f2 mixColor result eps |
	f1 := Form extent: 1@1 depth: 32.
	f2 := Form extent: 1@1 depth: 32.
	eps := 0.5 / 255.
	0 to: 255 do:[:i|
		f1 colorAt: 0@0 put: Color transparent.
		mixColor := Color red alpha: i / 255.0.
		f2 colorAt: 0@0 put: mixColor.
		mixColor := f2 colorAt: 0@0.
		bb := BitBlt toForm: f1.
		bb sourceForm: f2.
		bb combinationRule: Form blend.
		bb copyBits.
		result := f1 colorAt: 0@0.
		self assert: (result red - mixColor alpha) abs < eps.
		self assert: result alpha = mixColor alpha.
	].! !

!BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:13'!
testAlphaCompositing2Simulated
	"self run: #testAlphaCompositing2Simulated"

	| bb f1 f2 mixColor result eps |
	Smalltalk at: #BitBltSimulation ifPresent: [:bitblt|
	f1 := Form extent: 1@1 depth: 32.
	f2 := Form extent: 1@1 depth: 32.
	eps := 0.5 / 255.
	0 to: 255 do:[:i|
		f1 colorAt: 0@0 put: Color transparent.
		mixColor := Color red alpha: i / 255.0.
		f2 colorAt: 0@0 put: mixColor.
		mixColor := f2 colorAt: 0@0.
		bb := BitBlt toForm: f1.
		bb sourceForm: f2.
		bb combinationRule: Form blend.
		bb copyBitsSimulated.
		result := f1 colorAt: 0@0.
		self assert: (result red - mixColor alpha) abs < eps.
		self assert: result alpha = mixColor alpha.
	].]! !

!BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:13'!
testAlphaCompositingSimulated
	"self run: #testAlphaCompositingSimulated"
	
	| bb f1 f2 mixColor result eps |
	Smalltalk at: #BitBltSimulation ifPresent:[:bitblt|

	f1 := Form extent: 1@1 depth: 32.
	f2 := Form extent: 1@1 depth: 32.
	eps := 0.5 / 255.
	0 to: 255 do:[:i|
		f1 colorAt: 0@0 put: Color blue.
		mixColor := Color red alpha: i / 255.0.
		f2 colorAt: 0@0 put: mixColor.
		mixColor := f2 colorAt: 0@0.
		bb := BitBlt toForm: f1.
		bb sourceForm: f2.
		bb combinationRule: Form blend.
		bb copyBitsSimulated.
		result := f1 colorAt: 0@0.
		self assert: (result red - mixColor alpha) abs < eps.
		self assert: (result blue - (1.0 - mixColor alpha)) abs < eps.
		self assert: result alpha = 1.0.
	]].! !

!BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:13'!
testPeekerUnhibernateBug
	"self run: #testPeekerUnhibernateBug"

	| bitBlt |
	bitBlt := BitBlt bitPeekerFromForm: Display.
	bitBlt destForm hibernate.
	self shouldnt:[bitBlt pixelAt: 1@1] raise: Error.! !

!BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:14'!
testPokerUnhibernateBug
	"self run: #testPokerUnhibernateBug"

	| bitBlt |
	bitBlt := BitBlt bitPokerToForm: Display.
	bitBlt sourceForm hibernate.
	self shouldnt:[bitBlt pixelAt: 1@1 put: 0] raise: Error.! !
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: '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: 'initialize-release'!
release

	super release.
	squareForm release.
	squareForm _ nil! !


!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: 'CdG 10/17/2005 20:51'!
fileOut

	| fileName |
	fileName := UIManager default 
		request: 'File name?' translated
		initialAnswer: 'Filename.form'.
	fileName isEmpty ifTrue: [^ self].
	Cursor normal
		showWhile: [model writeOnFileNamed: fileName].
! !

!BitEditor methodsFor: 'menu messages' stamp: 'BG 12/5/2003 13:53'!
getCurrentColor
	| formExtent form c |
	c := Color colorFromPixelValue: color depth: Display depth.
	formExtent _ 30@30" min: 10@ 10//(2+1@2)".  "compute this better"
	form _ Form extent: formExtent depth: Display depth.
	form borderWidth: 5.
	form border: form boundingBox width: 4 fillColor: Color white.
	form fill: form boundingBox fillColor: c.

	^form! !

!BitEditor methodsFor: 'menu messages' stamp: 'BG 12/5/2003 13:21'!
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: Display depth.
	squareForm fillColor: aColor.
	self changed: #getCurrentColor! !

!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 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 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: '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: '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: 'private' stamp: 'BG 12/4/2003 10:18'!
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 _ ColorSystemView 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: 'BG 12/5/2003 13:40'!
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.
		aSwitchView _ PluggableButtonView
			on: button
			getState: #isOn
			action: #turnOn
			label: #getCurrentColor.

		index = 1
			ifTrue: [button onAction: [menuView model setColor: Color fromUser.
									  aSwitchView label: menuView model getCurrentColor;
									                  displayView
					                     ]
				    ]
			ifFalse: [button onAction: [menuView model setTransparentColor]].

		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: 'accessing' stamp: 'ar 3/3/2001 16:11'!
atAllPut: value
	"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>
	super atAllPut: value.! !

!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' stamp: 'ar 9/21/2001 23:06'!
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 |
	(byte < 0 or:[byte > 255]) ifTrue:[^self errorImproperStore].
	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: 'ar 3/3/2001 16:18'!
byteSize
	^self size * 4! !

!Bitmap methodsFor: 'accessing' stamp: 'nk 7/30/2004 17:53'!
copyFromByteArray: byteArray 
	"This method should work with either byte orderings"

	| myHack byteHack |
	myHack := Form new hackBits: self.
	byteHack := Form new hackBits: byteArray.
	SmalltalkImage current  isLittleEndian ifTrue: [byteHack swapEndianness].
	byteHack displayOn: myHack! !

!Bitmap methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'!
defaultElement
	"Return the default element of the receiver"
	^0! !

!Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:41'!
integerAt: index
	"Return the integer at the given index"
	| word |
	<primitive: 165>
	word _ self basicAt: index.
	word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations"
	^word >= 16r80000000	"Negative?!!"
		ifTrue:["word - 16r100000000"
				(word bitInvert32 + 1) negated]
		ifFalse:[word]! !

!Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:42'!
integerAt: index put: anInteger
	"Store the integer at the given index"
	| word |
	<primitive: 166>
	anInteger < 0
		ifTrue:["word _ 16r100000000 + anInteger"
				word _ (anInteger + 1) negated bitInvert32]
		ifFalse:[word _ anInteger].
	self  basicAt: index put: word.
	^anInteger! !

!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: 'as yet unclassified' stamp: 'yo 2/18/2004 18:28'!
asByteArray
	"Faster way to make a byte array from me.
	copyFromByteArray: makes equal Bitmap."
	| f bytes hack |
	f _ Form extent: 4@self size depth: 8 bits: self.
	bytes _ ByteArray new: self size * 4.
	hack _ Form new hackBits: bytes.
	SmalltalkImage current isLittleEndian ifTrue:[hack swapEndianness].
	hack copyBits: f boundingBox
		from: f
		at: (0@0)
		clippingBox: hack boundingBox
		rule: Form over
		fillColor: nil
		map: nil.

	"f displayOn: hack."
	^ bytes.
! !

!Bitmap methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 21:51'!
copy

	^self clone! !


!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' stamp: 'nk 12/31/2003 16:02'!
storeBits: startBit to: stopBit on: aStream 
	"Store my bits as a hex string, breaking the lines every 100 bytes or 
	so to comply with the maximum line length limits of Postscript (255 
	bytes). "
	| lineWidth |
	lineWidth := 0.
	self
		do: [:word | 
			startBit
				to: stopBit
				by: -4
				do: [:shift | 
					aStream nextPut: (word >> shift bitAnd: 15) asHexDigit.
					lineWidth := lineWidth + 1].
			(lineWidth > 100)
				ifTrue: [aStream cr.
					lineWidth := 0]].
	lineWidth > 0 ifTrue: [ aStream cr ].! !

!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: '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: '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: '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 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)]! !


!Bitmap class methodsFor: 'utilities' stamp: 'sd 6/28/2003 09:33'!
swapBytesIn: aNonPointerThing from: start to: stop
	"Perform a bigEndian/littleEndian byte reversal of my words.
	We only intend this for non-pointer arrays.  Do nothing if I contain pointers."
	| hack blt |
	"The implementation is a hack, but fast for large ranges"
	hack _ Form new hackBits: aNonPointerThing.
	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.
! !
TestCase subclass: #BitmapBugz
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Bugs'!

!BitmapBugz methodsFor: 'as yet unclassified' stamp: 'ar 8/2/2003 19:21'!
testBitmapByteAt
	| bm |
	bm := Bitmap new: 1.
	1 to: 4 do:[:i|
		self should:[bm byteAt: i put: 1000] raise: Error.
	].! !
OrientedFillStyle subclass: #BitmapFillStyle
	instanceVariableNames: 'form tileFlag'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Fills'!
!BitmapFillStyle commentStamp: '<historical>' prior: 0!
A BitmapFillStyle fills using any kind of form.

Instance variables:
	form	<Form>	The form to be used as fill.
	tileFlag	<Boolean>	If true, then the form is repeatedly drawn to fill the area.!


!BitmapFillStyle methodsFor: 'accessing' stamp: 'wiz 1/16/2005 20:17'!
direction

 

	^direction ifNil:[direction :=( (normal y @ normal x negated) *  form width / form height ) rounded]! !

!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: 'wiz 1/16/2005 20:18'!
normal
	^normal ifNil:[normal := ((direction y negated @ direction x) *  form height / form width ) rounded]! !

!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: 'converting' stamp: 'ar 11/11/1998 22:41'!
asColor
	^form colorAt: 0@0! !


!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: '*Morphic-Balloon' stamp: 'dgd 10/17/2003 22:34'!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"
	aMenu add: 'choose new graphic' translated target: self selector: #chooseNewGraphicIn:event: argument: aMorph.
	aMenu add: 'grab new graphic' translated target: self selector: #grabNewGraphicIn:event: argument: aMorph.
	super addFillStyleMenuItems: aMenu hand: aHand from: aMorph.! !

!BitmapFillStyle methodsFor: '*Morphic-Balloon' stamp: 'nk 6/12/2004 09:59'!
chooseNewGraphicIn: aMorph event: evt 
	"Used by any morph that can be represented by a graphic"
	| aGraphicalMenu |
	aGraphicalMenu := GraphicalMenu new
				initializeFor: self
				withForms: aMorph reasonableBitmapFillForms
				coexist: true.
	aGraphicalMenu selector: #newForm:forMorph:;
		 argument: aMorph.
	evt hand attachMorph: aGraphicalMenu! !

!BitmapFillStyle methodsFor: '*Morphic-Balloon' stamp: 'wiz 8/30/2003 16:54'!
grabNewGraphicIn: aMorph event: evt 
	"Used by any morph that can be represented by a graphic"
	| fill |
	fill _ Form fromUser.
	fill boundingBox area = 0
		ifTrue: [^ self].
	self form: fill.
	self direction: fill width @ 0.
	self normal: 0 @ fill height.
	aMorph changed! !

!BitmapFillStyle methodsFor: '*Morphic-Balloon' 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: 'KLC 1/27/2004 13:33'!
fromForm: aForm
	| fs |
	fs := self form: aForm.
	fs origin: 0@0.
	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! !
TestCase subclass: #BitmapStreamTests
	instanceVariableNames: 'random array stream'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tests-Bugs'!
!BitmapStreamTests commentStamp: 'nk 3/7/2004 14:26' prior: 0!
This is an incomplete test suite for storing and reading various word- and short-word subclasses of ArrayedCollection.

It demonstrates some problems with filing in of certain kinds of arrayed objects, including:

ShortPointArray
ShortIntegerArray
ShortRunArray
WordArray
MatrixTransform2x3

In 3.6b-5331, I get 8 passed/6 failed/6 errors (not counting the MatrixTransform2x3 tests, which were added later).

I ran into problems when trying to read back the SqueakLogo flash character morph, after I'd done a 'save morph to disk' from its debug menu.

The words within the ShortPointArrays and ShortRunArrays were reversed.
!


!BitmapStreamTests methodsFor: 'Running' stamp: 'stephaneducasse 2/3/2006 22:39'!
setUp
	random := Random new.! !


!BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'!
testMatrixTransform2x3WithImageSegment
	array := MatrixTransform2x3 new.
	1 to: 6 do: [ :i | array at: i put: self randomFloat ].
	self validateImageSegment
	! !

!BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'!
testMatrixTransform2x3WithRefStream
	array := MatrixTransform2x3 new.
	1 to: 6 do: [ :i | array at: i put: self randomFloat ].
	self validateRefStream
	! !

!BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'!
testMatrixTransform2x3WithRefStreamOnDisk
	array := MatrixTransform2x3 new.
	1 to: 6 do: [ :i | array at: i put: self randomFloat ].
	self validateRefStreamOnDisk	! !

!BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'!
testMatrixTransform2x3WithSmartRefStream
	array := MatrixTransform2x3 new.
	1 to: 6 do: [ :i | array at: i put: self randomFloat ].
	self validateSmartRefStream
	! !

!BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'stephaneducasse 2/3/2006 22:39'!
testMatrixTransform2x3WithSmartRefStreamOnDisk
	array := MatrixTransform2x3 new.
	1 to: 6 do: [ :i | array at: i put: self randomFloat ].
	self validateSmartRefStreamOnDisk
	! !


!BitmapStreamTests methodsFor: 'tests-misc' stamp: 'stephaneducasse 2/3/2006 22:39'!
testOtherClasses

	#(WordArrayForSegment FloatArray PointArray IntegerArray SoundBuffer String ShortPointArray ShortIntegerArray WordArray Array DependentsArray   ByteArray Bitmap ColorArray ) do: [:s | | a |
		a := (Smalltalk at: s) new: 3.
		self assert: (a basicSize * a bytesPerBasicElement = a byteSize). ]
! !


!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortIntegerArrayReadRefStream2
	|refStrm|
	refStrm := ReferenceStream on: ((RWBinaryOrTextStream with: (ByteArray withAll: #(20 6 17 83 104 111 114 116 73 110 116 101 103 101 114 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3))) reset; binary).
	self assert: (refStrm next = (ShortIntegerArray with: 0 with: 1 with: 2 with: 3)).! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortIntegerArrayWithImageSegment
	array := ShortIntegerArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
	self validateImageSegment
	! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortIntegerArrayWithRefStream

	array := ShortIntegerArray with: 0 with: 1 with: 2 with: 3.
	self validateRefStream
	! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortIntegerArrayWithRefStream2
	array := ShortIntegerArray with: 0 with: 1 with: 2 with: 3.
	self validateRefStream.
	self assert: stream byteStream contents = (ByteArray withAll: #(20 6 17 83 104 111 114 116 73 110 116 101 103 101 114 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3))
	
! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortIntegerArrayWithRefStreamOnDisk
	array := ShortIntegerArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
	self validateRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortIntegerArrayWithSmartRefStream
	array := ShortIntegerArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
	self validateSmartRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortIntegerArrayWithSmartRefStream2
	array := ShortIntegerArray with: 0 with: 1 with: 2 with: 3.
	self validateSmartRefStream.
	self assert: (stream contents asByteArray last: 15) = (ByteArray withAll: #(0 0 0 2  0 0  0 1  0 2  0 3  33 13 13))
	
! !

!BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortIntegerArrayWithSmartRefStreamOnDisk
	array := ShortIntegerArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
	self validateSmartRefStreamOnDisk
	! !


!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortPointArrayWithImageSegment
	array := ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateImageSegment 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortPointArrayWithRefStream
	array := ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortPointArrayWithRefStream2
	array := ShortPointArray with: 0@1 with: 2@3.
	self validateRefStream.
	self assert: stream byteStream contents = (ByteArray withAll: #(20 6 15 83 104 111 114 116 80 111 105 110 116 65 114 114 97 121  0 0 0 2  0 0  0 1  0 2  0 3 ))
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortPointArrayWithRefStreamOnDisk
	array := ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortPointArrayWithSmartRefStream
	array := ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateSmartRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortPointArrayWithSmartRefStream2
	array := ShortPointArray with: 0@1 with: 2@3.
	self validateSmartRefStream.
	self assert: (stream contents asByteArray last: 15) = (ByteArray withAll: #(0 0 0 2  0 0  0 1  0 2  0 3  33 13 13))
	! !

!BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortPointArrayWithSmartRefStreamOnDisk
	array := ShortPointArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
	self validateSmartRefStreamOnDisk
	! !


!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39'!
createSampleShortRunArray
	^ShortRunArray newFrom: { 0. 1. 1. 2. 2. 2. 3. 3. 3. 3 }! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortRunArrayWithImageSegment
	array := self createSampleShortRunArray.
	self validateImageSegment 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortRunArrayWithRefStream
	array := self createSampleShortRunArray.
	self validateRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortRunArrayWithRefStreamOnDisk
	array := self createSampleShortRunArray.
	self validateRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortRunArrayWithSmartRefStream
	array := self createSampleShortRunArray.
	self validateSmartRefStream 
	! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortRunArrayWithSmartRefStream2
	array := self createSampleShortRunArray.
	self validateSmartRefStream.
	self assert: (stream contents asByteArray last: 23) = (ByteArray withAll: #(0 0 0 4 0 1 0 0 0 2 0 1 0 3 0 2 0 4 0 3 33 13 13))

! !

!BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testShortRunArrayWithSmartRefStreamOnDisk
	array := self createSampleShortRunArray.
	self validateSmartRefStreamOnDisk
	! !


!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testWordArrayWithImageSegment
	array := WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateImageSegment
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testWordArrayWithRefStream
	array := WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateRefStream
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testWordArrayWithRefStreamOnDisk
	array := WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateRefStreamOnDisk
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testWordArrayWithSmartRefStream
	array := WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateSmartRefStream
	! !

!BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'stephaneducasse 2/3/2006 22:39'!
testWordArrayWithSmartRefStreamOnDisk
	array := WordArray new: 10.
	1 to: 10 do: [ :i | array at: i put: self randomWord ].
	self validateSmartRefStreamOnDisk
	! !


!BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'!
randomFloat
	"Answer a random 32-bit float"
	| w |
	random seed: (w := random nextValue).
	^w! !

!BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:33'!
randomShortInt
	^((random next * 65536) - 32768) truncated! !

!BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:00'!
randomShortPoint
	^(((random next * 65536) @ (random next * 65536)) - (32768 @ 32768)) truncated! !

!BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'!
randomWord
	"Answer a random 32-bit integer"
	| w |
	random seed: (w := random nextValue).
	^w truncated! !

!BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'!
validateImageSegment
	"array is set up with an array."
	| other filename |
	filename := 'bitmapStreamTest.extSeg'.

	FileDirectory default deleteFileNamed: filename ifAbsent: [ ].

	(ImageSegment new copyFromRootsForExport: (Array with: array))
         writeForExport: filename.

	other := (FileDirectory default readOnlyFileNamed: filename)
		fileInObjectAndCode.

	self assert: array = other originalRoots first! !

!BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'!
validateRefStream
	"array is set up with an array."
	| other rwstream |
	rwstream := RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6).

	stream := ReferenceStream on: rwstream.
	stream nextPut: array; close.

	rwstream position: 0.
	stream := ReferenceStream on: rwstream.
	other := stream next.
	stream close.

	self assert: array = other! !

!BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'!
validateRefStreamOnDisk
	"array is set up with an array."
	| other filename |

	filename := 'bitmapStreamTest.ref'.
	FileDirectory default deleteFileNamed: filename ifAbsent: [ ].

	stream := ReferenceStream fileNamed: filename.
	stream nextPut: array; close.

	stream := ReferenceStream fileNamed: filename.
	other := stream next.
	stream close.

	self assert: array = other! !

!BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'!
validateSmartRefStream
	"array is set up with an array."
	| other |
	stream := RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6).
	stream binary.
	stream fileOutClass: nil andObject: array.
	stream position: 0.
	stream binary.
	other := stream fileInObjectAndCode.
	self assert: array = other! !

!BitmapStreamTests methodsFor: 'private' stamp: 'stephaneducasse 2/3/2006 22:39'!
validateSmartRefStreamOnDisk
	"array is set up with an array."
	| other filename |

	filename := 'bitmapStreamTest.ref'.
	FileDirectory default deleteFileNamed: filename ifAbsent: [ ].

	stream := FileDirectory default fileNamed: filename.
	stream fileOutClass: nil andObject: array.
	stream close.

	stream := FileDirectory default fileNamed: filename.
	other := stream fileInObjectAndCode.
	stream close.

	self assert: array = other! !
BlobMorph subclass: #BlobMPEGMorph
	instanceVariableNames: 'mpegLogic form movieDrawArea primary quadNumber'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Movies-Player'!
!BlobMPEGMorph commentStamp: '<historical>' prior: 0!
Ok this is a little follow on to David's BlobMorph. Why not embedded a movie in the blob I thought. So with a few minutes of help from John Maloney we have something very interesting.

Enjoy John M McIntosh <johnmci@smalltalkconsulting.com> Dec 2000. (Christmas early)!


!BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 16:02'!
form
	^form! !

!BlobMPEGMorph methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
form: aForm
	form := aForm! !

!BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 12/19/2000 16:01'!
movieDrawArea
	^movieDrawArea! !

!BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 15:54'!
mpegLogic
	^mpegLogic! !

!BlobMPEGMorph methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
mpegLogic: aValue
	mpegLogic := aValue! !

!BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 12/19/2000 15:45'!
primary
	^primary! !

!BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 12/19/2000 21:52'!
quadNumber
	^quadNumber! !

!BlobMPEGMorph methodsFor: 'access' stamp: 'stephaneducasse 2/4/2006 20:48'!
quadNumber: aNumber
	quadNumber := aNumber! !

!BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 15:59'!
stream
	^0! !


!BlobMPEGMorph methodsFor: 'drawing' stamp: 'stephaneducasse 2/4/2006 20:48'!
drawOn: aCanvas 
	"Display the receiver, a spline curve, approximated by straight line 
	segments. Fill with the MPEG movie"

	| cm f filled quadRect |

	cm := Bitmap new: 2.
	cm at: 1 put: 0.
	cm at: 2 put: 32767.
	f := Form extent: self extent depth: 16.
	filled := self filledForm.
	(BitBlt toForm: f) sourceForm: filled;
		 sourceRect: filled boundingBox;
		
		destRect: (0 @ 0 extent: filled extent);
		 colorMap: cm;
		 combinationRule: Form over;
		 copyBits.
	quadNumber = 1
		ifTrue: [quadRect := Rectangle origin: form boundingBox topLeft corner: form boundingBox center].
	quadNumber = 2
		ifTrue: [quadRect := Rectangle origin: form boundingBox topCenter corner: form boundingBox rightCenter].
	quadNumber = 3
		ifTrue: [quadRect := Rectangle origin: form boundingBox leftCenter corner: form boundingBox bottomCenter].
	quadNumber = 4
		ifTrue: [quadRect := Rectangle origin: form boundingBox center corner: form boundingBox bottomRight].
	(BitBlt toForm: f) sourceForm: form;
		 sourceRect: quadRect;
		
		destRect: (0 @ 0 extent: f extent);
		 combinationRule: Form and;
		 copyBits.
	aCanvas image: f at: self position.
	self drawBorderOn: aCanvas.
	self drawArrowsOn: aCanvas! !

!BlobMPEGMorph methodsFor: 'drawing' stamp: 'JMM 1/4/2001 11:07'!
playStream: aStream
	mpegLogic playStream: aStream.
! !

!BlobMPEGMorph methodsFor: 'drawing' stamp: 'JMM 12/19/2000 16:41'!
playVideoStream: aStream
	mpegLogic playVideoStream: aStream.
! !


!BlobMPEGMorph methodsFor: 'initialization' stamp: 'aoy 2/15/2003 21:43'!
initialize: primaryFlag mpegPlayer: aMpegPlayerOrFileName 
	| rect sizeToOverLapBoundary |
	primary := primaryFlag.
	rect := self bounds.
	sizeToOverLapBoundary := 3.0.
	mpegLogic := primary 
				ifTrue:  
					[form := Form 
								extent: ((sizeToOverLapBoundary * rect width) 
										@ (sizeToOverLapBoundary * rect height)) truncated
								depth: 32.
					movieDrawArea := SketchMorph withForm: form.
					MPEGPlayer playFile: aMpegPlayerOrFileName onMorph: movieDrawArea]
				ifFalse: 
					[form := aMpegPlayerOrFileName form.
					movieDrawArea := aMpegPlayerOrFileName movieDrawArea.
					aMpegPlayerOrFileName mpegLogic]! !

!BlobMPEGMorph methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:48'!
initializeBlobShape

	| verts modifier |
	verts := {59@40. 74@54. 79@74. 77@93. 57@97. 37@97. 22@83. 15@67. 22@50. 33@35. 47@33}.
	modifier := 0 @ 0.
	(self quadNumber = 2) ifTrue: [ modifier := 0 @ 75].
	(self quadNumber = 3) ifTrue: [ modifier := 75 @ 0].
	(self quadNumber = 4) ifTrue: [ modifier := 75 @ 75].
	verts := verts + modifier.
	self 
		vertices: verts
		color: self color
		borderWidth: 1
		borderColor: Color black! !

!BlobMPEGMorph methodsFor: 'initialization' stamp: 'JMM 1/4/2001 10:54'!
initializeChildMpegPlayer: aMpegPlayerOrFileName  
	self initialize: false mpegPlayer: aMpegPlayerOrFileName ! !

!BlobMPEGMorph methodsFor: 'initialization' stamp: 'JMM 1/4/2001 10:54'!
initializePrimaryMpegPlayer: aMpegPlayerOrFileName  
	self initialize: true mpegPlayer: aMpegPlayerOrFileName  ! !


!BlobMPEGMorph methodsFor: 'stepping' stamp: 'JMM 10/19/2000 15:57'!
adjustColors
	^self! !

!BlobMPEGMorph methodsFor: 'stepping' stamp: 'JMM 12/19/2000 15:39'!
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: 60) max: 20) "was min: 80"
				degrees: (((thisDeg min: nextDeg-5) max: prevDeg+5) min: dincr*2+prevDeg)) ].
	^ new
! !

!BlobMPEGMorph methodsFor: 'stepping' stamp: 'JMM 12/19/2000 15:29'!
mergeBlobs
	^self! !


!BlobMPEGMorph methodsFor: 'testing' stamp: 'JMM 10/19/2000 16:29'!
stepTime
	^1.0 / (self mpegLogic videoFrameRate: self stream) * 1000! !

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

BlobMPEGMorph class
	instanceVariableNames: ''!

!BlobMPEGMorph class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:48'!
buildMorphics: aFileName
	| primary child |

	primary := (self basicNew quadNumber: 1) initialize.
	self remember: primary.
	primary initializePrimaryMpegPlayer: aFileName.
	primary openInWorld.
	2 to: 4 do: [:i | 
		child := (self basicNew quadNumber: i) initialize.
		self remember: child.
		child initializeChildMpegPlayer: primary.
		child openInWorld].
	^primary
! !

!BlobMPEGMorph class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:48'!
newWithMovie: aFileName
	| primary |

	primary := self buildMorphics: aFileName.
	primary playStream: 0.
	^primary

! !

!BlobMPEGMorph class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:48'!
newWithMovieNoSound: aFileName
	| primary |

	primary := self buildMorphics: aFileName.
	primary playVideoStream: 0.
	^primary

! !
PolygonMorph subclass: #BlobMorph
	instanceVariableNames: 'random velocity sneaky'
	classVariableNames: 'AllBlobs'
	poolDictionaries: ''
	category: 'MorphicExtras-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: 'debug and other' stamp: 'sma 2/12/2000 13:08'!
installModelIn: aWorld
	"Overwritten to not add handles to the receiver."! !


!BlobMorph methodsFor: 'geometry' stamp: 'tk 7/14/2001 11:06'!
setConstrainedPosition: aPoint hangOut: partiallyOutside
	"Deal with dragging the blob over another blob which results in spontaneous deletations."

	self owner ifNil: [^ self].
	super setConstrainedPosition: aPoint hangOut: false.
		"note that we keep them from overlapping"! !


!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 methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ random next < 0.25
		ifTrue: [Color random]
		ifFalse: [Color random alpha: random next * 0.4 + 0.4]! !

!BlobMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:42'!
initialize
	"initialize the state of the receiver"
	random _ Random new.
	sneaky _ random next < 0.75.
	super initialize.
""
	self beSmoothCurve; initializeBlobShape; 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: '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: 'ccn 8/28/2001 20:51'!
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 isNil or: [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 and presenter' 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: 'submorphs-add/remove' stamp: 'sma 2/6/2000 17:41'!
delete
	self class delete: self.
	super delete! !


!BlobMorph methodsFor: 'testing' stamp: 'sma 2/6/2000 18:41'!
stepTime
	"Answer the desired time between steps in milliseconds."

	^ 125! !

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

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! !


!BlobMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:20'!
descriptionForPartsBin
	^ self partName:	'Blob'
		categories:		#('Demo')
		documentation:	'A patch of primordial slime'! !
ParseNode subclass: #BlockArgsNode
	instanceVariableNames: 'temporaries'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
Error subclass: #BlockCannotReturn
	instanceVariableNames: 'result deadHome'
	classVariableNames: ''
	poolDictionaries: ''
	category: '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: 'ajh 2/6/2002 11:12'!
deadHome

	^ deadHome! !

!BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'!
deadHome: context

	deadHome _ context! !

!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! !
Object subclass: #BlockClosure
	instanceVariableNames: 'method environment'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Contexts'!
!BlockClosure commentStamp: 'ajh 7/19/2004 14:57' prior: 0!
A BlockClosure is a block of Smalltalk code (enclosed within []) that may be executed later by sending #valueWithArguments: (or one of its variants) to it.  A block can take arguments by specifying the names of the arguments in the beginning of the block, as in "[:arg1 :arg2 | ...]", and can have its own local temps, as in "[:arg1 |  | temp1 temp2 | ...]".  The block may reference variables outside its scope directly by name.  It also may return from its home context by using ^, otherwise, the value of the last statement is returned to the sender of valueWithArguments:.

Structure:

 method		CompiledMethod2
			Contains the block's code.  It has its own method separate from its home method.

 environment  ClosureEnvironment | Object
			The lexical environment the block was created in.  The environment only contains variables that were captured/reference by this block or other sister blocks. If only self and/or its instance variables are captured then the environment is simply the receiver object.


Each non-inlined blocks has its own CompiledMethod. These block methods are held in the literals of the home method and sent the #createBlock: message at runtime to create BlockClosures. Home method temps captured by inner blocks are placed inside a ClosureEnvironment when the home method is started. This environment is supplied as the argument to each #createBlock:. When #value... is sent to a block closure, its method is executed in a new MethodContext with its closure environment as the receiver. The block method accesses its free variables (captured home temps) via this environment.

Closure environments are nested mirroring the nesting of blocks. Each environment points to its parent environment (the top method environment has no parent). However, for efficiency, environments that have no captured temps are skipped (never created). For example, an environment's parent may actually be its grand-parent. There is no special parent variable in ClosureEnvironment, it is just another named variable such as 'self' or 'parent env' (special var with space so it can't be referenced by user code), or it may not be their at all.

A block closure that returns to its home context does so by finding the thisContext sender that owns the top environment. A return inside a block forces the home environment to be created even if it has no captured temps. Each context holds its local environment (which holds its captured temps) in its #myEnv instance variable (previously the unused #receiverMap variable). Code that references captured temps goes through the #myEnv context variable.

Block closures are totally separate from their home context. They are reentrant and each activation has its own block-local temps. So except for the thisContext psuedo-variable, contexts are now LIFO (assuming we get rid of old block contexts and recompile the whole image).
!


!BlockClosure methodsFor: 'accessing' stamp: 'ajh 6/24/2004 03:40'!
env

	^ environment! !

!BlockClosure methodsFor: 'accessing' stamp: 'ajh 2/6/2003 13:24'!
hasLiteralSuchThat: testBlock

	(testBlock value: method) ifTrue: [^ true].
	^ method hasLiteralSuchThat: testBlock! !

!BlockClosure methodsFor: 'accessing' stamp: 'ajh 1/31/2003 16:59'!
hasLiteralThorough: literal
	"Answer true if literal is identical to any literal imbedded in my method"

	method == literal ifTrue: [^ true].
	^ method hasLiteralThorough: literal! !

!BlockClosure methodsFor: 'accessing' stamp: 'ajh 2/6/2003 13:27'!
hasMethodReturn
	"Answer whether the receiver has a return ('^') in its code."

	^ self method remoteReturns! !

!BlockClosure methodsFor: 'accessing' stamp: 'ajh 1/21/2003 13:16'!
isBlock

	^ true! !

!BlockClosure methodsFor: 'accessing' stamp: 'ajh 5/21/2001 14:01'!
method

	^ method! !

!BlockClosure methodsFor: 'accessing' stamp: 'ajh 5/28/2001 14:37'!
numArgs

	^ method numArgs! !


!BlockClosure methodsFor: 'comparing' stamp: 'ajh 6/24/2004 03:56'!
= other

	self class == other class ifFalse: [^ false].
	self env = other env ifFalse: [^ false].
	^ self method = other method! !

!BlockClosure methodsFor: 'comparing' stamp: 'ajh 10/4/2002 17:12'!
hash

	^ method hash! !


!BlockClosure methodsFor: 'controlling' stamp: 'md 10/14/2004 17:04'!
doWhileFalse: conditionBlock
	"Evaluate the receiver once, then again as long the value of conditionBlock is false."
 
	| result |
	[result _ self value.
	conditionBlock value] whileFalse.

	^ result! !

!BlockClosure methodsFor: 'controlling' stamp: 'md 10/14/2004 17:04'!
doWhileTrue: conditionBlock
	"Evaluate the receiver once, then again as long the value of conditionBlock is true."
 
	| result |
	[result _ self value.
	conditionBlock value] whileTrue.

	^ result! !

!BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'!
repeat
	"Evaluate the receiver repeatedly, ending only if the block explicitly returns."

	[self value. true] whileTrue! !

!BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'!
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! !

!BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'!
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: []! !

!BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'!
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]! !

!BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'!
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: []! !

!BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'!
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]! !


!BlockClosure methodsFor: 'evaluating' stamp: 'md 10/14/2004 17:02'!
bench
	"See how many times I can value in 5 seconds.  I'll answer a meaningful description."

	| startTime endTime count |
	count _ 0.
	endTime _ Time millisecondClockValue + 5000.
	startTime _ Time millisecondClockValue.
	[ Time millisecondClockValue > endTime ] whileFalse: [ self value.  count _ count + 1 ].
	endTime _ Time millisecondClockValue.
	^count = 1
		ifTrue: [ ((endTime - startTime) // 1000) printString, ' seconds.' ]
		ifFalse:
			[ ((count * 1000) / (endTime - startTime)) asFloat printString, ' per second.' ]! !

!BlockClosure methodsFor: 'evaluating' stamp: 'md 10/14/2004 17:03'!
durationToRun
	"Answer the duration taken to execute this block."

	^ Duration milliSeconds: self timeToRun

! !

!BlockClosure methodsFor: 'evaluating' stamp: 'ajh 1/13/2002 13:04'!
ifError: errorHandlerBlock
	"Evaluate the block represented by the receiver, and normally return it's value.  If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned.  The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)."
	"Examples:
		[1 whatsUpDoc] ifError: [:err :rcvr | 'huh?'].
		[1 / 0] ifError: [:err :rcvr |
			'ZeroDivide' = err
				ifTrue: [Float infinity]
				ifFalse: [self error: err]]
"

	^ self on: Error do: [:ex |
		errorHandlerBlock valueWithPossibleArgs: {ex description. ex receiver}]! !

!BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/15/2001 15:57'!
timeToRun
	"Answer the number of milliseconds taken to execute this block."

	^ Time millisecondsToRun: self
! !

!BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:43'!
value
	"Evaluate the block with no args. Fail if the block expects other than 0 arguments."

	^ environment executeMethod: method! !

!BlockClosure methodsFor: 'evaluating' stamp: 'md 3/28/2006 20:17'!
valueWithExit 
	  self value: [ ^nil ]! !

!BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:43'!
value: arg1
	"Evaluate the block with the given args. Fail if the block expects other than 1 arguments."

	^ environment with: arg1 executeMethod: method! !

!BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:43'!
value: arg1 value: arg2
	"Evaluate the block with the given args. Fail if the block expects other than 2 arguments."

	^ environment with: arg1 with: arg2 executeMethod: method! !

!BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:42'!
value: arg1 value: arg2 value: arg3
	"Evaluate the block with the given args. Fail if the block expects other than 3 arguments."

	^ environment with: arg1 with: arg2 with: arg3 executeMethod: method! !

!BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:42'!
value: arg1 value: arg2 value: arg3 value: arg4 
	"Evaluate the block with the given args. Fail if the block expects other than 4 arguments."

	^ environment with: arg1 with: arg2 with: arg3 with: arg4 executeMethod: method! !

!BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:42'!
valueWithArguments: anArray 
	"Evaluate the block with given args. Fail if the block expects other than the given number of arguments."

	^ environment withArgs: anArray executeMethod: method! !

!BlockClosure methodsFor: 'evaluating' stamp: 'ajh 1/28/2003 14:44'!
valueWithPossibleArgs: anArray 

	| n |
	(n _ self numArgs) = 0 ifTrue: [^ self value].
	n = anArray size ifTrue: [^ self valueWithArguments: anArray].
	^ self valueWithArguments: (n > anArray size
		ifTrue: [anArray, (Array new: n - anArray size)]
		ifFalse: [anArray copyFrom: 1 to: n])! !

!BlockClosure methodsFor: 'evaluating' stamp: 'md 10/14/2004 17:03'!
valueWithPossibleArgument: anArg 

     "Evaluate the block represented by the receiver. 
     If the block requires one argument, use anArg, if it requires more than one,
     fill up the rest with nils."

	self numArgs = 0 ifTrue: [^self value].
	self numArgs = 1 ifTrue: [^self value: anArg].
	self numArgs  > 1 ifTrue: [^self valueWithArguments: {anArg}, (Array new: self numArgs  - 1)]! !

!BlockClosure methodsFor: 'evaluating' stamp: 'ar 2/23/2005 11:48'!
valueWithin: aDuration onTimeout: timeoutBlock
	"Evaluate the receiver.
	If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead"

	| theProcess delay watchdog done result |

	aDuration <= Duration zero ifTrue: [^ timeoutBlock value ].

	"the block will be executed in the current process"
	theProcess := Processor activeProcess.
	delay := aDuration asDelay.

	"make a watchdog process"
	watchdog := [
		delay wait. 	"wait for timeout or completion"
		done ifFalse: [ theProcess signalException: TimedOut ] 
	] newProcess.

	"watchdog needs to run at high priority to do its job"
	watchdog priority: Processor timingPriority.

	"catch the timeout signal"
	^ [	done := false.
		watchdog resume.				"start up the watchdog"
		result := self value.				"evaluate the receiver"
		done := true.						"it has completed, so ..."
		delay delaySemaphore signal.	"arrange for the watchdog to exit"
		result ]
			on: TimedOut do: [ :e | timeoutBlock value ].
! !


!BlockClosure methodsFor: 'exceptions' stamp: 'ajh 7/15/2001 16:14'!
assert
	self assert: self! !

!BlockClosure methodsFor: 'exceptions' stamp: 'ajh 5/20/2004 17:37'!
ensure: aBlock
	"Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes."

	| returnValue b |
	<primitive: 198>
	returnValue := self value.
	"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: [
		"nil out aBlock temp before evaluating aBlock so it is not executed again if aBlock remote returns"
		b _ aBlock.
		thisContext tempAt: 1 put: nil.  "aBlock _ nil"
		b value.
	].
	^ returnValue! !

!BlockClosure methodsFor: 'exceptions' stamp: 'ajh 1/21/2003 17:50'!
ifCurtailed: aBlock
	"Evaluate the receiver with an abnormal termination action."

	<primitive: 198>
	^ self value! !

!BlockClosure methodsFor: 'exceptions' stamp: 'ajh 2/1/2003 00:30'!
on: exception do: handlerAction
	"Evaluate the receiver in the scope of an exception handler."

	| handlerActive |
	<primitive: 199>  "just a marker, fail and execute the following"
	handlerActive _ true.
	^ self value! !

!BlockClosure methodsFor: 'exceptions' stamp: 'ajh 1/31/2003 20:41'!
onDNU: selector do: handleBlock
	"Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)"

	^ self on: MessageNotUnderstood do: [:exception |
		exception message selector = selector
			ifTrue: [handleBlock valueWithPossibleArgs: {exception}]
			ifFalse: [exception pass]
	  ]! !

!BlockClosure methodsFor: 'exceptions' stamp: 'ajh 7/26/2002 11:49'!
valueUninterruptably
	"Prevent remote returns from escaping the sender.  Even attempts to terminate (unwind) this process will be halted and the process will resume here.  A terminate message is needed for every one of these in the sender chain to get the entire process unwound."

	^ self ifCurtailed: [^ self]! !


!BlockClosure methodsFor: 'initializing' stamp: 'ajh 6/24/2004 03:50'!
env: aClosureEnvironment
	"the outer environment"

	environment _ aClosureEnvironment! !

!BlockClosure methodsFor: 'initializing' stamp: 'ajh 5/28/2001 18:37'!
method: compiledMethod
	"compiledMethod will be the code I execute when I'm evaluated"

	method _ compiledMethod! !


!BlockClosure methodsFor: 'printing' stamp: 'ajh 9/10/2002 16:53'!
printOn: aStream 

	super printOn: aStream.
	aStream space; nextPutAll: self identityHashPrintString! !


!BlockClosure methodsFor: 'scheduling' stamp: 'ajh 6/24/2004 03:43'!
asContext
	"Create a MethodContext that is ready to execute self.  Assumes self takes no args (if it does the args will be nil)"

	^ MethodContext 
		sender: nil
		receiver: environment
		method: method
		arguments: #()! !

!BlockClosure methodsFor: 'scheduling' stamp: 'ajh 1/27/2003 18:51'!
callCC
	"Call with current continuation, ala Scheme.
	Evaluate self against a copy of the sender's call stack, which can be resumed later"

	^ self value: thisContext sender asContinuation! !

!BlockClosure methodsFor: 'scheduling' stamp: 'ajh 7/15/2001 16:03'!
fork
	"Create and schedule a Process running the code in the receiver."

	^ self newProcess resume! !

!BlockClosure methodsFor: 'scheduling' stamp: 'ajh 10/16/2002 11:14'!
forkAndWait
	"Suspend current process while self runs"

	| semaphore |
	semaphore _ Semaphore new.
	[self ensure: [semaphore signal]] fork.
	semaphore wait.
! !

!BlockClosure methodsFor: 'scheduling' stamp: 'ajh 9/29/2001 21:00'!
forkAt: priority 
	"Create and schedule a Process running the code in the receiver at the given priority. Answer the newly created process."

	^ self newProcess
		priority: priority;
		resume! !

!BlockClosure methodsFor: 'scheduling' stamp: 'md 10/14/2004 17:04'!
forkAt: priority named: name
	"Create and schedule a Process running the code in the receiver at the
	given priority and having the given name. Answer the newly created 
	process."

	| forkedProcess |
	forkedProcess := self newProcess.
	forkedProcess priority: priority.
	forkedProcess name: name.
	^ forkedProcess resume! !

!BlockClosure methodsFor: 'scheduling' stamp: 'md 10/14/2004 17:05'!
forkNamed: aString
	"Create and schedule a Process running the code in the receiver and
	having the given name."

	^ self newProcess name: aString; resume! !

!BlockClosure methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:23'!
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] asContext
		priority: Processor activePriority! !

!BlockClosure methodsFor: 'scheduling' stamp: 'ajh 7/27/2002 12:26'!
simulate
	"Like run except interpret self using Smalltalk instead of VM.  It is much slower."

	^ self newProcess simulate! !


!BlockClosure methodsFor: 'private' stamp: 'ajh 1/16/2002 18:32'!
copyForSaving
	"obsolete"! !

!BlockClosure methodsFor: 'private' stamp: 'ajh 1/16/2002 18:32'!
fixTemps
	"obsolete"! !

!BlockClosure methodsFor: 'private' stamp: 'ajh 1/31/2003 12:53'!
reentrant! !

!BlockClosure methodsFor: 'private' stamp: 'ajh 7/15/2001 16:13'!
valueError

	self error: 'Incompatible number of args'! !

!BlockClosure methodsFor: 'private' stamp: 'ajh 7/26/2002 11:47'!
valueUnpreemptively
	"Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!"
	"Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! 
	After you've done all that thinking, go right ahead and use it..."

	| activeProcess oldPriority result |
	activeProcess _ Processor activeProcess.
	oldPriority _ activeProcess priority.
	activeProcess priority: Processor highestPriority.
	result _ self ensure: [activeProcess priority: oldPriority].
	"Yield after restoring priority to give the preempted processes a chance to run"
	Processor yield.
	^result! !

!BlockClosure methodsFor: 'private' stamp: 'ajh 6/24/2004 03:34'!
veryDeepInner: deepCopier
	"Do not copy my method (which can be shared because CompiledMethod2 are basically treated as immutables) or my home context (MethodContexts are treated as immutables too)"

	super veryDeepInner: deepCopier.
	method _ method.
	environment _ environment.
! !

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

BlockClosure class
	instanceVariableNames: ''!
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: 'accessing' stamp: 'RAH 4/25/2000 19:49'!
argumentCount
	"Answers the number of arguments needed to evaluate the receiver."
	#Valuable.
	^ self numArgs! !

!BlockContext methodsFor: 'accessing' stamp: 'ajh 1/24/2003 12:35'!
blockHome

	^ self home! !

!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' stamp: 'ajh 1/31/2003 23:29'!
finalBlockHome

	^ self home! !

!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: 'md 4/27/2006 15:14'!
hasInstVarRef
	"Answer whether the receiver references an instance variable."

	| method scanner end printer |

	home ifNil: [^false].
	method _ self method.
	end _ self endPC.
	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' stamp: 'ajh 1/21/2003 13:16'!
isBlock

	^ true! !

!BlockContext methodsFor: 'accessing' stamp: 'ajh 1/31/2003 12:12'!
isExecutingBlock

	^ true! !

!BlockContext methodsFor: 'accessing' stamp: 'ajh 9/28/2001 02:16'!
isMethodContext

	^ false! !

!BlockContext methodsFor: 'accessing'!
method
	"Answer the compiled method in which the receiver was defined."

	^home method! !

!BlockContext methodsFor: 'accessing' stamp: 'mdr 4/10/2001 10:34'!
numArgs
	"Answer the number of arguments that must be used to evaluate this block"

	^nargs! !

!BlockContext methodsFor: 'accessing'!
receiver 
	"Refer to the comment in ContextPart|receiver."

	^home receiver! !

!BlockContext methodsFor: 'accessing' stamp: 'ajh 1/30/2003 15:45'!
reentrant
	"Copy before calling so multiple activations can exist"

	^ self copy! !

!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: 'controlling' stamp: 'jf 9/3/2003 16:45'!
doWhileFalse: conditionBlock
	"Evaluate the receiver once, then again as long the value of conditionBlock is false."
 
	| result |
	[result _ self value.
	conditionBlock value] whileFalse.

	^ result! !

!BlockContext methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:39'!
doWhileTrue: conditionBlock
	"Evaluate the receiver once, then again as long the value of conditionBlock is true."
 
	| result |
	[result _ self value.
	conditionBlock value] whileTrue.

	^ result! !

!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: 'evaluating' stamp: 'cmm 2/16/2003 16:08'!
bench
	"See how many times I can value in 5 seconds.  I'll answer a meaningful description."

	| startTime endTime count |
	count _ 0.
	endTime _ Time millisecondClockValue + 5000.
	startTime _ Time millisecondClockValue.
	[ Time millisecondClockValue > endTime ] whileFalse: [ self value.  count _ count + 1 ].
	endTime _ Time millisecondClockValue.
	^count = 1
		ifTrue: [ ((endTime - startTime) // 1000) printString, ' seconds.' ]
		ifFalse:
			[ ((count * 1000) / (endTime - startTime)) asFloat printString, ' per second.' ]! !

!BlockContext methodsFor: 'evaluating' stamp: 'brp 9/25/2003 13:49'!
durationToRun
	"Answer the duration taken to execute this block."

	^ Duration milliSeconds: self timeToRun

! !

!BlockContext methodsFor: 'evaluating' stamp: 'ajh 1/13/2002 13:36'!
ifError: errorHandlerBlock
	"Evaluate the block represented by the receiver, and normally return it's value.  If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned.  The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)."
	"Examples:
		[1 whatsUpDoc] ifError: [:err :rcvr | 'huh?'].
		[1 / 0] ifError: [:err :rcvr |
			'ZeroDivide' = err
				ifTrue: [Float infinity]
				ifFalse: [self error: err]]
"

	^ self on: Error do: [:ex |
		errorHandlerBlock valueWithPossibleArgs: {ex description. ex receiver}]! !

!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' stamp: 'nk 3/11/2001 11:49'!
valueWithEnoughArguments: anArray
	"call me with enough arguments from anArray"
	| args |
	(anArray size == self numArgs)
		ifTrue: [ ^self valueWithArguments: anArray ].

	args _ Array new: self numArgs.
	args replaceFrom: 1
		to: (anArray size min: args size)
		with: anArray
		startingAt: 1.

	^ self valueWithArguments: args! !

!BlockContext methodsFor: 'evaluating' stamp: 'md 3/28/2006 20:17'!
valueWithExit 
	  self value: [ ^nil ]! !

!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 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: 'jrp 10/10/2004 22:28'!
valueSupplyingAnswer: anObject

	^ (anObject isCollection and: [anObject isString not])
		ifTrue: [self valueSupplyingAnswers: {anObject}]
		ifFalse: [self valueSupplyingAnswers: {{'*'. anObject}}]! !

!BlockContext methodsFor: 'evaluating' stamp: 'md 11/10/2004 18:43'!
valueSupplyingAnswers: aListOfPairs
	"evaluate the block using a list of questions / answers that might be called upon to
	automatically respond to Object>>confirm: or FillInTheBlank requests"

	^ [self value] 
		on: ProvideAnswerNotification
		do: 
			[:notify | | answer caption |
			
			caption _ notify messageText withSeparatorsCompacted. "to remove new lines"
			answer _ aListOfPairs
				detect: 
					[:each | caption = each first or:
						[caption includesSubstring: each first caseSensitive: false] or:
						[each first match: caption]]
					ifNone: [nil].
			answer
				ifNotNil: [notify resume: answer second]
				ifNil: 
					[ | outerAnswer |
					outerAnswer _ ProvideAnswerNotification signal: notify messageText.
					outerAnswer 
						ifNil: [notify resume] 
						ifNotNil: [notify resume: outerAnswer]]]! !

!BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/10/2004 22:28'!
valueSuppressingAllMessages

	^ self valueSuppressingMessages: #('*')! !

!BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/4/2004 18:59'!
valueSuppressingMessages: aListOfStrings

	^ self
		valueSuppressingMessages: aListOfStrings
		supplyingAnswers: #()! !

!BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/4/2004 18:58'!
valueSuppressingMessages: aListOfStrings supplyingAnswers: aListOfPairs

	^ self valueSupplyingAnswers: aListOfPairs, (aListOfStrings collect: [:each | {each. true}])! !

!BlockContext methodsFor: 'evaluating' stamp: 'md 7/30/2005 21:22'!
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>

	anArray isArray ifFalse: [^self error: 'valueWithArguments: expects an array'].
	self numArgs = anArray size
		ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.']
		ifFalse: [self error: 
			'This block accepts ' ,self numArgs printString, ' argument', (self numArgs = 1 ifTrue:[''] ifFalse:['s']) , 
			', but was called with ', anArray size printString, '.']

! !

!BlockContext methodsFor: 'evaluating' stamp: 'md 10/7/2004 15:24'!
valueWithPossibleArgs: anArray 

     "Evaluate the block represented by the receiver. 
     If the block requires arguments, take them from anArray. If anArray is too
     large, the rest is ignored, if it is too small, use nil for the other arguments"
 
	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)

! !

!BlockContext methodsFor: 'evaluating' stamp: 'md 10/7/2004 15:26'!
valueWithPossibleArgument: anArg 

     "Evaluate the block represented by the receiver. 
     If the block requires one argument, use anArg, if it requires more than one,
     fill up the rest with nils."

	self numArgs = 0 ifTrue: [^self value].
	self numArgs = 1 ifTrue: [^self value: anArg].
	self numArgs  > 1 ifTrue: [^self valueWithArguments: {anArg}, (Array new: self numArgs  - 1)]! !

!BlockContext methodsFor: 'evaluating' stamp: 'ar 2/23/2005 11:48'!
valueWithin: aDuration onTimeout: timeoutBlock
	"Evaluate the receiver.
	If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead"

	| theProcess delay watchdog done result |

	aDuration <= Duration zero ifTrue: [^ timeoutBlock value ].

	"the block will be executed in the current process"
	theProcess := Processor activeProcess.
	delay := aDuration asDelay.

	"make a watchdog process"
	watchdog := [
		delay wait. 	"wait for timeout or completion"
		done ifFalse: [ theProcess signalException: TimedOut ] 
	] newProcess.

	"watchdog needs to run at high priority to do its job"
	watchdog priority: Processor timingPriority.

	"catch the timeout signal"
	^ [	done := false.
		watchdog resume.				"start up the watchdog"
		result := self value.				"evaluate the receiver"
		done := true.						"it has completed, so ..."
		delay delaySemaphore signal.	"arrange for the watchdog to exit"
		result ]
			on: TimedOut do: [ :e | timeoutBlock value ].
! !


!BlockContext methodsFor: 'exceptions' stamp: 'sma 5/11/2000 19:38'!
assert
	self assert: self! !

!BlockContext methodsFor: 'exceptions' stamp: 'ajh 3/4/2004 22:36'!
ensure: aBlock
	"Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes."

	| returnValue b |
	<primitive: 198>
	returnValue := self value.
	"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: [
		"nil out aBlock temp before evaluating aBlock so it is not executed again if aBlock remote returns"
		b _ aBlock.
		thisContext tempAt: 1 put: nil.  "aBlock _ nil"
		b value.
	].
	^ returnValue! !

!BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 21:43'!
ifCurtailed: aBlock
	"Evaluate the receiver with an abnormal termination action."

	<primitive: 198>
	^ self value! !

!BlockContext methodsFor: 'exceptions' stamp: 'ar 3/6/2001 14:25'!
on: exception do: handlerAction
	"Evaluate the receiver in the scope of an exception handler."
	| handlerActive |
	<primitive: 199>
	handlerActive _ true.
	^self value! !

!BlockContext methodsFor: 'exceptions' stamp: 'ajh 10/9/2001 16:51'!
onDNU: selector do: handleBlock
	"Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)"

	^ self on: MessageNotUnderstood do: [:exception |
		exception message selector = selector
			ifTrue: [handleBlock valueWithPossibleArgs: {exception}]
			ifFalse: [exception pass]
	  ]! !

!BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 21:53'!
valueUninterruptably
	"Temporarily make my home Context unable to return control to its sender, to guard against circumlocution of the ensured behavior."

	^ self ifCurtailed: [^ self]! !


!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: 'initialize-release' stamp: 'ajh 7/18/2003 21:49'!
privRefresh
	"Reinitialize the receiver so that it is in the state it was at its creation."

	pc _ startpc.
	self stackp: 0.
	nargs timesRepeat: [  "skip arg popping"
		self nextInstruction selector = #popIntoTemporaryVariable:
			ifFalse: [self halt: 'unexpected bytecode instruction']
	].
! !


!BlockContext methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:35'!
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 from: self.
	home _ save.
	sender _ nil.
	^ dest! !


!BlockContext methodsFor: 'printing' stamp: 'md 2/22/2006 15:53'!
decompile
	^ home method decompilerClass new decompileBlock: self! !

!BlockContext methodsFor: 'printing' stamp: 'md 2/20/2006 13:46'!
decompileString
	^self decompile decompileString.! !

!BlockContext methodsFor: 'printing' stamp: 'LC 1/6/2002 13:07'!
fullPrintOn: aStream
	aStream print: self; cr.
	(self decompile ifNil: ['--source missing--']) fullPrintOn: aStream
! !

!BlockContext methodsFor: 'printing' stamp: 'md 2/27/2006 12:36'!
printOn: aStream
	| blockString truncatedBlockString code |

	home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil'].
	aStream nextPutAll: '[] in '.
	super printOn: aStream.
	aStream nextPutAll: ' '.
	code := self decompile.
	blockString := code 
		ifNil: [''] 
		ifNotNil: [(code printString replaceAll: Character cr with: Character space)
						replaceAll: Character tab with: Character space].
	truncatedBlockString _ blockString truncateWithElipsisTo: 80.
	truncatedBlockString size < blockString size ifTrue:
		[truncatedBlockString _ truncatedBlockString, ']}'].
	aStream nextPutAll: truncatedBlockString.
! !

!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: 'scheduling' stamp: 'ajh 2/10/2003 14:23'!
asContext

	^ self! !

!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: 'ajh 10/16/2002 11:14'!
forkAndWait
	"Suspend current process and execute self in new process, when it completes resume current process"

	| semaphore |
	semaphore _ Semaphore new.
	[self ensure: [semaphore signal]] fork.
	semaphore wait.
! !

!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: 'svp 6/23/2003 10:59'!
forkAt: priority named: name
	"Create and schedule a Process running the code in the receiver at the
	given priority and having the given name. Answer the newly created 
	process."

	| forkedProcess |
	forkedProcess := self newProcess.
	forkedProcess priority: priority.
	forkedProcess name: name.
	^ forkedProcess resume! !

!BlockContext methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'!
forkNamed: aString
	"Create and schedule a Process running the code in the receiver and
	having the given name."

	^ self newProcess name: aString; resume! !

!BlockContext methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:25'!
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] asContext
		priority: Processor activePriority! !

!BlockContext methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:25'!
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] asContext
		priority: Processor activePriority! !

!BlockContext methodsFor: 'scheduling' stamp: 'sr 6/14/2004 15:19'!
valueAt: blockPriority 
	"Evaluate the receiver (block), with another priority as the actual one 
	and restore it afterwards. The caller should be careful with using 
	higher priorities."
	| activeProcess result outsidePriority |
	activeProcess := Processor activeProcess.
	outsidePriority := activeProcess priority.
	activeProcess priority: blockPriority.
	result := self
				ensure: [activeProcess priority: outsidePriority].
	"Yield after restoring lower priority to give the preempted processes a  
	chance to run."
	blockPriority > outsidePriority
		ifTrue: [Processor yield].
	^ result! !


!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: 'system simulation' stamp: 'hmm 7/30/2001 18:03'!
stepToSendOrReturn
	pc = startpc ifTrue: [
		"pop args first"
		self numArgs timesRepeat: [self step]].
	^super stepToSendOrReturn! !


!BlockContext methodsFor: '*services-base' stamp: 'rr 3/21/2006 11:53'!
valueWithRequestor: aRequestor 
	"To do later: make the fillInTheBlank display more informative captions.
	Include the description of the service, and maybe record steps"

	^ self numArgs isZero 
		ifTrue: [self value]
		ifFalse: [self value: aRequestor]! !


!BlockContext methodsFor: 'private' stamp: 'ajh 1/24/2003 20:36'!
aboutToReturn: result through: firstUnwindContext 
	"Called from VM when an unwindBlock is found between self and its home.  Return to home's sender, executing unwind blocks on the way."

	self home return: result! !

!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: 'ajh 1/27/2003 21:18'!
copyTo: aContext blocks: dict
	"Copy self and my sender chain down to, but not including, aContext.  End of copied chain will have nil sender.  BlockContexts whose home is also copied will point to the copy.  However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread.  So an error will be raised if one of these tries to return directly to its home."

	| copy |
	self == aContext ifTrue: [^ nil].
	copy _ self copy.
	(dict at: self home ifAbsentPut: [OrderedCollection new]) add: copy.
	self sender ifNotNil: [
		copy privSender: (self sender copyTo: aContext blocks: dict)].
	^ copy! !

!BlockContext methodsFor: 'private' stamp: 'md 4/27/2006 15:14'!
endPC
	"Determine end of block from long jump preceding it"
	^(self method at: startpc - 2)
				\\ 16 - 4 * 256
				+ (self method at: startpc - 1) + startpc - 1.! !

!BlockContext methodsFor: 'private' stamp: 'tfei 3/20/2000 00:24'!
hideFromDebugger

	^home ~~ nil and: [home hideFromDebugger]! !

!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' stamp: 'ajh 7/7/2004 13:43'!
myEnv
	"polymorphic with MethodContext"

	^ nil! !

!BlockContext methodsFor: 'private' stamp: 'ajh 1/27/2003 21:08'!
privHome: context

	home _ context! !

!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: 'private' stamp: 'ar 3/2/2001 01:16'!
valueUnpreemptively
	"Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!"
	"Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! 
	After you've done all that thinking, go right ahead and use it..."
	| activeProcess oldPriority result |
	activeProcess _ Processor activeProcess.
	oldPriority _ activeProcess priority.
	activeProcess priority: Processor highestPriority.
	result _ self ensure: [activeProcess priority: oldPriority].
	"Yield after restoring priority to give the preempted processes a chance to run"
	Processor yield.
	^result! !


!BlockContext methodsFor: 'private-exceptions' stamp: 'ar 3/9/2001 01:18'!
ifProperUnwindSupportedElseSignalAboutToReturn
	"A really ugly hack to simulate the necessary unwind behavior for VMs not having proper unwind support"
	<primitive: 123>
	"The above indicates new EH primitives supported. In this case is identical to #value. Sender is expected to use [nil] ifProperUnwindSupportedElseSignalAboutToReturn."
	^ExceptionAboutToReturn signal.! !

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

BlockContext class
	instanceVariableNames: ''!
TestCase subclass: #BlockContextTest
	instanceVariableNames: 'aBlockContext contextOfaBlockContext'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Methods'!
!BlockContextTest commentStamp: 'jrp 10/17/2004 12:22' prior: 0!
I am an SUnit Test of BlockContext and its supertype ContextPart.  See also MethodContextTest.

My fixtures are:
aBlockContext     - just some trivial block, i.e., [100@100 corner: 200@200].

NOTES ABOUT AUTOMATING USER INPUTS

When executing non-interactive programs you will inevitably run into programs (like SqueakMap or Monticello installation packages -- and other programs, to be fair) that require user input during their execution and these sort of problems shoot the whole non-interactiveness of your enclosing program.

BlockContext helper methods have been made available and tests of these helpers are provided in this class to demonstrate that it can intercept PopUpMenu and FillInTheBlankMorph requests for user interaction.  Of course, PopUpMenu and FillInTheBlankMorph were modified to first signal a ProvideAnswerNotification and if someone handles that (e.g. the enclosing block) then the user interaction will be circumvented and the provided answer of the enclosing block will be used.  The basic syntax looks like:

	[self confirm: 'Install spyware?'] valueSupplyingAnswer: #('Install spyware?' false)

There a few variants on this theme making it easy to provide a literal list of answers for the block so that you can handle a bunch of questions in a block with appropriate answers.

Additionally, it is possible to suppress Object>>inform: modal dialog boxes as these get in the way of automating anything.  After applying this changeset you should be able to tryout the following code snippets to see the variants on this theme that are available.

Examples:

So you don't need any introduction here -- this one works like usual.
[self inform: 'hello'. #done] value.

Now let's suppress all inform: messages.
[self inform: 'hello'; inform: 'there'. #done] valueSuppressingAllMessages.

Here we can just suppress a single inform: message.
[self inform: 'hi'; inform: 'there'. #done] valueSuppressingMessages: #('there')

Here you see how you can suppress a list of messages.
[self inform: 'hi'; inform: 'there'; inform: 'bill'. #done] valueSuppressingMessages: #('hi' 'there')

Enough about inform:, let's look at confirm:. As you see this one works as expected.
[self confirm: 'You like Squeak?'] value

Let's supply answers to one of the questions -- check out the return value.
[{self confirm: 'You like Smalltalk?'. self confirm: 'You like Squeak?'}]
	valueSupplyingAnswer: #('You like Smalltalk?' true)

Here we supply answers using only substrings of the questions (for simplicity).
[{self confirm: 'You like Squeak?'. self confirm: 'You like MVC?'}]
	valueSupplyingAnswers: #( ('Squeak' true) ('MVC' false) )

This time let's answer all questions exactly the same way.
[{self confirm: 'You like Squeak?'. self confirm: 'You like Morphic?'}]
	valueSupplyingAnswer: true
	
And, of course, we can answer FillInTheBlank questions in the same manner.
[FillInTheBlank request: 'What day is it?']
	valueSupplyingAnswer: 'the first day of the rest of your life'
	
We can also return whatever the initialAnswer of the FillInTheBlank was by using the #default answer.
[FillInTheBlank request: 'What day is it?' initialAnswer: DateAndTime now dayOfWeekName]
	valueSupplyingAnswer: #default
	
Finally, you can also do regex matches on any of the question text (or inform text) (should you have VB-Regex enhancements in your image).
[FillInTheBlank request: 'What day is it?']
	valueSupplyingAnswers: { {'What day.*\?'. DateAndTime now dayOfWeekName} }!


!BlockContextTest methodsFor: 'setup' stamp: 'md 9/6/2005 19:56'!
setUp
	super setUp.
	aBlockContext _ [100@100 corner: 200@200].
	contextOfaBlockContext _ thisContext.! !


!BlockContextTest methodsFor: 'testing' stamp: 'rbb 3/1/2005 10:23'!
testSupplyAnswerOfFillInTheBlank

	self should: ['blue' = ([UIManager default request: 'Your favorite color?'] 
		valueSupplyingAnswer: #('Your favorite color?' 'blue'))]! !

!BlockContextTest methodsFor: 'testing' stamp: 'rbb 3/1/2005 10:24'!
testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer

	self should: ['red' = ([UIManager default  request: 'Your favorite color?' initialAnswer: 'red'] 
		valueSupplyingAnswer: #('Your favorite color?' #default))]! !


!BlockContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 14:00'!
testBlockIsBottomContext
	self	should: [aBlockContext client ] raise: Error. "block's sender is nil, a block has no client"
	self assert: aBlockContext bottomContext = aBlockContext.
	self assert: aBlockContext secondFromBottom isNil.! !

!BlockContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 13:49'!
testCopyStack
	self assert: aBlockContext copyStack printString = aBlockContext printString.! !

!BlockContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 13:55'!
testFindContextSuchThat
	self assert: (aBlockContext findContextSuchThat: [:each| true]) printString = aBlockContext printString.
	self assert: (aBlockContext hasContext: aBlockContext).  ! !

!BlockContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 13:13'!
testNew
	self	should: [ContextPart new: 5] raise: Error.
	[ContextPart new: 5]
		ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:'].
	[ContextPart new]
		ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:'].	
	[ContextPart basicNew]
		ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:'].				

! !

!BlockContextTest methodsFor: 'tests' stamp: 'mjr 8/24/2003 18:27'!
testNoArguments
	[10
		timesRepeat: [:arg | 1 + 2]]
		ifError: [:err :rcvr | self deny: err = 'This block requires 1 arguments.'].
	[10
		timesRepeat: [:arg1 :arg2 | 1 + 2]]
		ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! !

!BlockContextTest methodsFor: 'tests' stamp: 'mjr 8/24/2003 18:25'!
testOneArgument
	| c |
	c _ OrderedCollection new.
	c add: 'hello'.
	[c
		do: [1 + 2]]
		ifError: [:err :rcvr | self deny: err = 'This block requires 0 arguments.'].
	[c
		do: [:arg1 :arg2 | 1 + 2]]
		ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! !

!BlockContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 12:50'!
testRunSimulated
	self assert: (ContextPart runSimulated: aBlockContext) class = Rectangle.! !

!BlockContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 13:59'!
testSetUp
	"Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'"
	self deny: aBlockContext isBlockClosure.
	self deny: aBlockContext isMethodContext.
	self deny: aBlockContext isPseudoContext.
	self deny: aBlockContext isDead.
	self assert: aBlockContext home = contextOfaBlockContext.
	self assert: aBlockContext blockHome = contextOfaBlockContext.
	self assert: aBlockContext receiver = self.
	self assert: (aBlockContext method isKindOf: CompiledMethod).
	self assert: aBlockContext methodNode selector = 'setUp'.
	self assert: (aBlockContext methodNodeFormattedAndDecorated: true) selector = 'setUp'.! !

!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/10/2004 22:19'!
testSupplyAnswerThroughNestedBlocks

	self should: [true = ([[self confirm: 'You like Smalltalk?'] 
		valueSupplyingAnswer: #('Blub' false)] valueSupplyingAnswer: #('Smalltalk' true))]! !

!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:27'!
testSupplyAnswerUsingOnlySubstringOfQuestion

	self should: [false = ([self confirm: 'You like Smalltalk?'] 
		valueSupplyingAnswer: #('like' false))]! !

!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/10/2004 22:31'!
testSupplyAnswerUsingRegexMatchOfQuestion

	(String includesSelector: #matchesRegex:) ifFalse: [^ self].
	
	self should: [true = ([self confirm: 'You like Smalltalk?'] 
		valueSupplyingAnswer: #('.*Smalltalk\?' true))]! !

!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/10/2004 22:17'!
testSupplyAnswerUsingTraditionalMatchOfQuestion

	self should: [true = ([self confirm: 'You like Smalltalk?'] 
		valueSupplyingAnswer: #('*Smalltalk#' true))]! !

!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:25'!
testSupplySameAnswerToAllQuestions

	self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: true)].
	
	self should: [#(true true) = ([{self confirm: 'One'. self confirm: 'Two'}] valueSupplyingAnswer: true)].! !

!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:39'!
testSupplySeveralAnswersToSeveralQuestions

	self should: [#(false true) = ([{self confirm: 'One'. self confirm: 'Two'}] 
		valueSupplyingAnswers: #( ('One' false) ('Two' true) ))].
	
	self should: [#(true false) = ([{self confirm: 'One'. self confirm: 'Two'}] 
		valueSupplyingAnswers: #( ('One' true) ('Two' false) ))]! !

!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:26'!
testSupplySpecificAnswerToQuestion

	self should: [false = ([self confirm: 'You like Smalltalk?'] 
		valueSupplyingAnswer: #('You like Smalltalk?' false))]! !

!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/4/2004 19:35'!
testSuppressInform

	self should: [[nil inform: 'Should not see this message or this test failed!!'] valueSuppressingAllMessages isNil]! !

!BlockContextTest methodsFor: 'tests' stamp: 'jrp 10/10/2004 22:29'!
testSuppressInformUsingStringMatchOptions

	self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('Should not see this message or this test failed!!')) isNil].
	
	self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('not see this message')) isNil].
	
	self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('*message*failed#')) isNil].
! !

!BlockContextTest methodsFor: 'tests' stamp: 'md 9/6/2005 19:58'!
testTallyInstructions
	self assert: (ContextPart tallyInstructions: aBlockContext) size = 15.! !

!BlockContextTest methodsFor: 'tests' stamp: 'md 9/6/2005 19:58'!
testTallyMethods
	self assert: (ContextPart tallyMethods: aBlockContext) size = 3.! !

!BlockContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 12:48'!
testTrace
	self assert: (ContextPart trace: aBlockContext) class = Rectangle.! !


!BlockContextTest methodsFor: 'tests - evaluating' stamp: 'tlk 5/31/2004 17:14'!
testValueWithArguments
	self
		should: [aBlockContext
				valueWithArguments: #(1 )]
		raise: Error.
	self
		shouldnt: [aBlockContext
				valueWithArguments: #()]
		raise: Error.
	[aBlockContext
		valueWithArguments: #(1 )]
		ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 0 arguments, but was called with 1.'].
	[[:i | 3 + 4]
		valueWithArguments: #(1 2)]
		ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 1 argument, but was called with 2.']! !

!BlockContextTest methodsFor: 'tests - evaluating' stamp: 'md 3/23/2006 13:52'!
testValueWithExitBreak

	| val |	

	[ :break |
	    1 to: 10 do: [ :i |
			val := i.
			i = 4 ifTrue: [break value].
		] 
	] valueWithExit.

	self assert: val = 4.! !

!BlockContextTest methodsFor: 'tests - evaluating' stamp: 'md 3/23/2006 13:52'!
testValueWithExitContinue

	| val last |	
	val := 0. 

	1 to: 10 do: [ :i |
		[ :continue |
			i = 4 ifTrue: [continue value].
			val := val + 1.
			last := i
		] valueWithExit.
	].

	self assert: val = 9.
	self assert: last = 10.	! !

!BlockContextTest methodsFor: 'tests - evaluating' stamp: 'md 10/7/2004 13:52'!
testValueWithPossibleArgs
	| block  blockWithArg blockWith2Arg |

	block := [1].
	blockWithArg  := [:arg | arg].
	blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}].

	self assert: (block valueWithPossibleArgs: #()) = 1.
	self assert: (block valueWithPossibleArgs: #(1)) = 1.
	
	self assert: (blockWithArg valueWithPossibleArgs: #()) = nil.
	self assert: (blockWithArg valueWithPossibleArgs: #(1)) = 1.
	self assert: (blockWithArg valueWithPossibleArgs: #(1 2)) = 1.

	self assert: (blockWith2Arg valueWithPossibleArgs: #()) = {nil .nil}.
	self assert: (blockWith2Arg valueWithPossibleArgs: #(1)) =  {1 . nil}.
	self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2)) =  #(1 2).
	self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2 3)) = #(1 2).
		

	! !

!BlockContextTest methodsFor: 'tests - evaluating' stamp: 'md 10/7/2004 13:59'!
testValueWithPossibleArgument
	| block  blockWithArg blockWith2Arg |

	block := [1].
	blockWithArg  := [:arg | arg].
	blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}].

	self assert: (block valueWithPossibleArgument: 1) = 1.
	
	self assert: (blockWithArg valueWithPossibleArgument: 1) = 1.
	
	self assert: (blockWith2Arg valueWithPossibleArgument: 1) = {1 . nil}.
	

	! !


!BlockContextTest methodsFor: 'tests - printing' stamp: 'md 2/22/2006 15:39'!
testDecompile
	self assert: ([3 + 4] decompile printString = '{[3 + 4]}').! !
ParseNode subclass: #BlockNode
	instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!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: '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: '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' stamp: 'hmm 7/17/2001 21:02'!
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.
		pc _ aStream position.
	].
	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: 'equation translation'!
statements
	^statements! !

!BlockNode methodsFor: 'equation translation'!
statements: val
	statements _ val! !


!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: 'hmm 7/15/2001 22:23'!
arguments: argNodes statements: statementsCollection returns: returnBool from: encoder sourceRange: range
	"Compile."

	encoder noteSourceRange: range forNode: self.
	^self
		arguments: argNodes
		statements: statementsCollection
		returns: returnBool
		from: encoder! !

!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: 'printing' stamp: 'md 2/22/2006 16:37'!
decompileString 
	"Answer a string description of the parse tree whose root is the receiver."

	^ self decompileText asString
! !

!BlockNode methodsFor: 'printing' stamp: 'md 2/22/2006 16:37'!
decompileText
	"Answer a text description of the parse tree whose root is the receiver."

	^ ColoredCodeStream contents: [:strm | self printOn: strm indent: 0]
! !

!BlockNode methodsFor: 'printing' stamp: 'md 8/14/2005 17:32'!
printArgumentsOn: aStream indent: level
	arguments size = 0
		ifTrue: [^ self].
	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: 'md 2/20/2006 13:37'!
printOn: aStream indent: 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: '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: '*eToys-tiles' stamp: 'RAA 2/27/2001 09:48'!
asMorphicCollectSyntaxIn: parent

	^parent 
		blockNodeCollect: self 
		arguments: arguments 
		statements: statements! !

!BlockNode methodsFor: '*eToys-tiles' stamp: 'RAA 2/16/2001 09:08'!
asMorphicSyntaxIn: parent

	^parent 
		blockNode: self 
		arguments: arguments 
		statements: statements! !

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

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: 'yo 5/17/2004 23:03'!
withJust: aNode
	^ self statements: (OrderedCollection with: aNode) returns: false! !
SmallLandColorTheme subclass: #BlueSmallLandColorTheme
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

!BlueSmallLandColorTheme methodsFor: 'initialization' stamp: 'dgd 3/12/2006 13:45'!
baseColors
	" 
	BlueSmallLandColorTheme apply.  
	"
	^ Array
		with: (Color fromArray: #(0.2 0.3 0.9 ))
		with: (Color fromArray: #(0.6 0.7 1.0 ))
		with: (Color fromArray: #(0.85 0.9 1.0 ))! !
BooklikeMorph subclass: #BookMorph
	instanceVariableNames: 'pages currentPage'
	classVariableNames: 'MethodHolders VersionNames VersionTimes'
	poolDictionaries: ''
	category: 'MorphicExtras-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: 'accessing' stamp: 'tk 12/12/2001 15:36'!
cardsOrPages
	"The turnable and printable entities"

	^ pages! !

!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: 'caching' stamp: 'tk 3/11/2002 12:05'!
releaseCachedState
	"Release the cached state of all my pages."

	super releaseCachedState.
	self removeProperty: #allText.	"the cache for text search"
	pages do: [:page | 
		page == currentPage ifFalse: [page fullReleaseCachedState]].
! !


!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: '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: 'halos and balloon help' 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: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color white! !

!BookMorph methodsFor: 'initialization' stamp: 'dgd 2/21/2003 23:10'!
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 second) 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 second.
	dict := remote first.
	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: 'ar 4/10/2005 18:42'!
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 isString ifTrue: [self inform: 'Sorry, ',strm. ^ nil].
	self setProperty: #url toValue: url.
	self fromRemoteStream: strm.
	^ self! !

!BookMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:09'!
initialize
"initialize the state of the receiver"
	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: 'dgd 2/14/2003 22:07'!
setInitialState
	self listDirection: #topToBottom;
	  wrapCentering: #topLeft;
	  hResizing: #shrinkWrap;
	  vResizing: #shrinkWrap;
	  layoutInset: 5.
	pageSize _ 160 @ 300.
	self enableDragNDrop! !


!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: 'dgd 9/21/2003 17:45'!
deletePage

	| message |
	message _ 
'Are you certain that you
want to delete this page and
everything that is on it? ' translated.
	(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: 'dgd 2/21/2003 23:10'!
insertPage: aPage pageSize: aPageSize atIndex: anIndex 
	| sz predecessor |
	sz := aPageSize 
				ifNil: [currentPage isNil ifTrue: [pageSize] ifFalse: [currentPage extent]]
				ifNotNil: [aPageSize].
	aPage extent: sz.
	(pages isEmpty | anIndex isNil or: [anIndex > pages size]) 
		ifTrue: [pages add: aPage]
		ifFalse: 
			[anIndex <= 1 
				ifTrue: [pages addFirst: aPage]
				ifFalse: 
					[predecessor := anIndex isNil 
								ifTrue: [currentPage]
								ifFalse: [pages at: anIndex].
					self pages add: aPage after: predecessor]].
	self goToPageMorph: aPage! !

!BookMorph methodsFor: 'insert and delete' stamp: 'dgd 2/21/2003 23:11'!
insertPageColored: aColor 
	"Insert a new page for the receiver, using the given color as its background color"

	| sz newPage bw bc |
	bc := currentPage isNil 
				ifTrue: 
					[sz := pageSize.
					bw := 0.
					Color blue muchLighter]
				ifFalse: 
					[sz := currentPage extent.
					bw := currentPage borderWidth.
					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 vResizeToFit: 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: 'dgd 2/21/2003 23:11'!
insertPageSilentlyAtEnd
	"Create a new page at the end of the book.  Do not turn to it."

	| sz newPage bw bc cc |
	cc := currentPage isNil 
				ifTrue: 
					[sz := pageSize.
					bw := 0.
					bc := Color blue muchLighter.
					color]
				ifFalse: 
					[sz := currentPage extent.
					bw := currentPage borderWidth.
					bc := currentPage borderColor.
					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 vResizeToFit: false.
	pages isEmpty 
		ifTrue: [pages add: (currentPage := newPage)	"had been none"]
		ifFalse: [pages add: newPage after: pages last].
	^newPage! !


!BookMorph methodsFor: 'layout' 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: 'menu' stamp: 'dgd 8/30/2003 21:13'!
addBookMenuItemsTo: aMenu hand: aHandMorph
	| controlsShowing subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	subMenu add: 'previous page' translated action: #previousPage.
	subMenu add: 'next page' translated action: #nextPage.
	subMenu add: 'goto page' translated action: #goToPage.
	subMenu add: 'insert a page' translated action: #insertPage.
	subMenu add: 'delete this page' translated action: #deletePage.

	controlsShowing _ self hasSubmorphWithProperty: #pageControl.
	controlsShowing
		ifTrue:
			[subMenu add: 'hide page controls' translated action: #hidePageControls.
			subMenu add: 'fewer page controls' translated action: #fewerPageControls]
		ifFalse:
			[subMenu add: 'show page controls' translated action: #showPageControls].
	self isInFullScreenMode ifTrue: [
		subMenu add: 'exit full screen' translated action: #exitFullScreen.
	] ifFalse: [
		subMenu add: 'show full screen' translated action: #goFullScreen.
	].
	subMenu addLine.
	subMenu add: 'sound effect for all pages' translated action: #menuPageSoundForAll:.
	subMenu add: 'sound effect this page only' translated action: #menuPageSoundForThisPage:.
	subMenu add: 'visual effect for all pages' translated action: #menuPageVisualForAll:.
	subMenu add: 'visual effect this page only' translated action: #menuPageVisualForThisPage:.

	subMenu addLine.
	subMenu add: 'sort pages' translated action: #sortPages:.
	subMenu add: 'uncache page sorter' translated action: #uncachePageSorter.
	(self hasProperty: #dontWrapAtEnd)
		ifTrue: [subMenu add: 'wrap after last page' translated selector: #setWrapPages: argument: true]
		ifFalse: [subMenu add: 'stop at last page' translated selector: #setWrapPages: argument: false].

	subMenu addLine.
	subMenu add: 'search for text' translated action: #textSearch.
	(aHandMorph pasteBuffer class isKindOf: PasteUpMorph class) ifTrue:
		[subMenu add: 'paste book page' translated	action: #pasteBookPage].

	subMenu add: 'send all pages to server' translated action: #savePagesOnURL.
	subMenu add: 'send this page to server' translated action: #saveOneOnURL.
	subMenu add: 'reload all from server' translated action: #reload.
	subMenu add: 'copy page url to clipboard' translated action: #copyUrl.
	subMenu add: 'keep in one file' translated action: #keepTogether.
	subMenu add: 'save as new-page prototype' translated action: #setNewPagePrototype.
	newPagePrototype ifNotNil:
		[subMenu add: 'clear new-page prototype' translated action: #clearNewPagePrototype].

	aMenu add: 'book...' translated subMenu: subMenu
! !

!BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:03'!
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' translated.
		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' translated.
	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: 'dgd 10/26/2003 13:04'!
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.' translated 
		initialAnswer: (
			self valueOfProperty: #nameOfThreadOfProjects ifAbsent: ['Projects on Parade' translated]
		).
	threadName isEmptyOrNil ifTrue: [^self].
	InternalThreadNavigationMorph 
		know: projectNames as: threadName;
		openThreadNamed: threadName atIndex: nil.
! !

!BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:05'!
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.' translated].
	Clipboard clipboardText: str asText.
! !

!BookMorph methodsFor: 'menu' stamp: 'md 9/27/2005 22:57'!
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"
	allText ifNotEmpty: [
		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: 'gm 2/22/2003 13:17'!
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 old |
	good := true.
	start := startIndex.
	strings := oldContainer ifNil: 
					["normal case"

					rawStrings]
				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 first) 
										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)
						startAt: startIndex
						container: oldContainer
						pageNum: pageNum	"recompute"]].
	(old := self valueOfProperty: #searchContainer) ifNotNil: 
			[(old respondsTo: #editor) 
				ifTrue: 
					[old editor selectFrom: 1 to: 0.	"trying to remove the previous selection!!"
					old changed]].
	good 
		ifTrue: 
			["have the exact string object"

			(container := oldContainer) ifNil: 
					[container := self 
								highlightText: keys first
								at: place
								in: insideOf]
				ifNotNil: 
					[container userString == insideOf 
						ifFalse: 
							[container := self 
										highlightText: keys first
										at: place
										in: insideOf]
						ifTrue: 
							[(container isTextMorph) 
								ifTrue: 
									[container editor selectFrom: place to: keys first size - 1 + place.
									container changed]]].
			self setProperty: #searchContainer toValue: container.
			self setProperty: #searchOffset toValue: place.
			self setProperty: #searchKey toValue: keys.	"override later"
			ActiveHand newKeyboardFocus: container.
			^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: 'dgd 10/26/2003 13:06'!
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://' translated initialAnswer: initial].
	^ SqueakPage stemUrl: url! !

!BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 12:59'!
goToPage
	| pageNum |
	pageNum _ FillInTheBlank request: 'Page?' translated initialAnswer: '0'.
	pageNum isEmptyOrNil ifTrue: [^true].
	self goToPage: pageNum asNumber.
! !

!BookMorph methodsFor: 'menu' stamp: 'gm 2/22/2003 13:17'!
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 isTextMorph) 
		ifTrue: 
			[container editor selectFrom: index to: stringToHilite size - 1 + index].
	container changed.
	^container! !

!BookMorph methodsFor: 'menu' stamp: 'dgd 4/3/2006 13:08'!
invokeBookMenu
	"Invoke the book's control panel menu."
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Book' translated.
	Preferences noviceMode
		ifFalse:[aMenu addStayUpItem].
	aMenu add: 'find...' translated action: #textSearch.
	aMenu add: 'go to page...' translated action: #goToPage.
	aMenu addLine.

	aMenu addList: {
		{'sort pages' translated.		#sortPages}.
		{'uncache page sorter' translated.	#uncachePageSorter}}.
	(self hasProperty: #dontWrapAtEnd)
		ifTrue: [aMenu add: 'wrap after last page' translated selector: #setWrapPages: argument: true]
		ifFalse: [aMenu add: 'stop at last page' translated selector: #setWrapPages: argument: false].
	aMenu addList: {
		{'make bookmark' translated.		#bookmarkForThisPage}.
		{'make thumbnail' translated.		#thumbnailForThisPage}}.
	aMenu addUpdating: #showingPageControlsString action: #toggleShowingOfPageControls.
	aMenu addUpdating: #showingFullScreenString action: #toggleFullScreen.

	aMenu addLine.
	aMenu add: 'sound effect for all pages' translated action: #menuPageSoundForAll:.
	aMenu add: 'sound effect this page only' translated action: #menuPageSoundForThisPage:.
	aMenu add: 'visual effect for all pages' translated action: #menuPageVisualForAll:.
	aMenu add: 'visual effect this page only' translated action: #menuPageVisualForThisPage:.

	aMenu addLine.
	(self primaryHand pasteBuffer class isKindOf: PasteUpMorph class) ifTrue:
		[aMenu add: 'paste book page' translated   action: #pasteBookPage].

	aMenu add: 'save as new-page prototype' translated action: #setNewPagePrototype.
	newPagePrototype ifNotNil: [
		aMenu add: 'clear new-page prototype' translated action: #clearNewPagePrototype].

	aMenu add: (self dragNDropEnabled ifTrue: ['close dragNdrop'] ifFalse: ['open dragNdrop']) translated
			action: #toggleDragNDrop.
	aMenu add: 'make all pages this size' translated action: #makeUniformPageSize.
	
	aMenu
		addUpdating: #keepingUniformPageSizeString
		target: self
		action: #toggleMaintainUniformPageSize.
	aMenu addLine.

	aMenu add: 'send all pages to server' translated action: #savePagesOnURL.
	aMenu add: 'send this page to server' translated action: #saveOneOnURL.
	aMenu add: 'reload all from server' translated action: #reload.
	aMenu add: 'copy page url to clipboard' translated action: #copyUrl.
	aMenu add: 'keep in one file' translated action: #keepTogether.

	aMenu addLine.
	aMenu add: 'load PPT images from slide #1' translated action: #loadImagesIntoBook.
	aMenu add: 'background color for all pages...' translated action: #setPageColor.
	aMenu add: 'make a thread of projects in this book' translated 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: 'nk 6/12/2004 09:23'!
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) isNil 
						ifTrue: [self savePagesOnURL]
						ifFalse: [self saveAsNumberedURLs]].
			form := Form 
						fromFileNamed: (directory fullNameFor: 'Slide' , filenumber asString).
			newpage := PasteUpMorph new extent: form extent.
			newpage addMorph: (World drawingClass 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) isNil 
		ifTrue: [self savePagesOnURL]
		ifFalse: [self saveAsNumberedURLs]! !

!BookMorph methodsFor: 'menu' stamp: 'nb 6/17/2003 12:25'!
makeUniformPageSize
	"Make all pages be of the same size as the current page."
	currentPage ifNil: [^ Beeper beep].
	self resizePagesTo: currentPage extent.
	newPagePrototype ifNotNil:
		[newPagePrototype extent: currentPage extent]! !

!BookMorph methodsFor: 'menu' stamp: 'em 3/30/2005 14:35'!
menuPageSoundFor: target event: evt
	| tSpec menu |
	tSpec _ self transitionSpecFor: target.
	menu _ (MenuMorph entitled: 'Choose a sound
(it is now ' translated, tSpec first translated, ')') defaultTarget: target.
	SoundService default sampledSoundChoices do:
		[:soundName |
		menu add: soundName translated 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: 'dgd 10/26/2003 13:39'!
menuPageVisualFor: target event: evt
	| tSpec menu subMenu directionChoices |
	tSpec _ self transitionSpecFor: target.
	menu _ (MenuMorph entitled: ('Choose an effect
(it is now {1})' translated format:{tSpec second asString translated})) defaultTarget: target.
	TransitionMorph allEffects do:
		[:effect |
		directionChoices _ TransitionMorph directionsForEffect: effect.
		directionChoices isEmpty
		ifTrue: [menu add: effect asString translated 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 asString translated target: target
						selector: #setProperty:toValue:
						argumentList: (Array with: #transitionSpec
									with: (Array with: tSpec first with: effect with: dir))].
				menu add: effect asString translated 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: 'dgd 10/26/2003 13: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://' translated
		initialAnswer: (self getStemUrl, '.bo').
	url notEmpty 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 notNil and: [sq contentsMorph isInMemory])
			ifTrue: [((out sqkPage lastChangeTime > sq lastChangeTime) or: 
					  [sq contentsMorph isNil]) 
						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: 'dgd 2/21/2003 23:12'!
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) isEmpty 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: 'dgd 2/21/2003 23:12'!
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) isNil.
	stem := self getStemUrl.	"user must approve"
	stem isEmpty 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: 'ar 4/10/2005 18: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 isString ifTrue: [^ self saveIndexOnURL].
	strm exists ifFalse: [^ self saveIndexOnURL].	"write whole thing if missing"
	strm _ strm asStream.
	strm isString ifTrue: [^ self saveIndexOnURL].
	remote _ strm fileInObjectAndCode.
	dict _ remote first.
	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.' translated].


	(pageURL _ aPage url) ifNil: [self error: 'just had one!!' translated].
	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: 'dgd 2/21/2003 23:12'!
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 isEmpty 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: 'dgd 10/26/2003 13:18'!
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.' translated.
		^ self].
	"Don't give the chance to put in a different place.  Assume named by number"
	((self valueOfProperty: #url) isNil and: [pages first url notNil]) ifTrue: [
		response _ (PopUpMenu labels: 'Old book
New book sharing old pages' translated)
				startUpWithCaption: 'Modify the old book, or make a new
book sharing its pages?' translated.
		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) isEmpty 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 isEmpty ifTrue: [^ self].
	ind _ pages identityIndexOf: pageMorph ifAbsent: [self error: 'where is the page?' translated].
	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: 'dgd 10/26/2003 13:20'!
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.' translated.
		^ 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' translated)
			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?' translated.
	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) isEmpty 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) isNil.
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: 'dgd 10/26/2003 12:58'!
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.' translated
		initialAnswer: str.
	wants _ wanted findTokens: Character separators.
	wants isEmpty ifTrue: [^ self].
	self getAllText.		"save in allText, allTextUrls"
	^ self findText: wants	"goes to the page and highlights the text"! !

!BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:14'!
textSearch: stringWithKeys 
	"search the text on all pages of this book"

	| wants |
	wants := stringWithKeys findTokens: Character separators.
	wants isEmpty 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: 'menu commands' stamp: 'di 1/4/1999 13:52'!
sortPages

	currentPage ifNotNil: [currentPage updateCachedThumbnail].
	^ super sortPages! !


!BookMorph methodsFor: 'menus' stamp: 'yo 7/2/2004 13:05'!
printPSToFile
	"Ask the user for a filename and print this morph as postscript."

	| fileName rotateFlag |
	fileName _ ('MyBook') translated asFileName.
	fileName _ FillInTheBlank request: 'File name? (".ps" will be added to end)' translated 
			initialAnswer: fileName.
	fileName isEmpty ifTrue: [^ Beeper beep].
	(fileName endsWith: '.ps') ifFalse: [fileName _ fileName,'.ps'].

	rotateFlag _ ((PopUpMenu labels:
'portrait (tall)
landscape (wide)' translated) 
			startUpWithCaption: 'Choose orientation...' translated) = 2.

	(FileStream newFileNamed: fileName asFileName)
		nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag); close.

! !


!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: 'sw 11/8/2002 13:31'!
goToPage: pageNumber transitionSpec: transitionSpec runTransitionScripts: aBoolean
	"Go the the given page number; use the transitionSpec supplied, and if the boolean parameter is true, run opening and closing scripts as appropriate"

	| pageMorph |
	pages isEmpty ifTrue: [^ self].
	pageMorph _ (self hasProperty: #dontWrapAtEnd)
		ifTrue: [pages atPin: pageNumber]
		ifFalse: [pages atWrap: pageNumber].
	^ self goToPageMorph: pageMorph transitionSpec: transitionSpec runTransitionScripts: aBoolean! !

!BookMorph methodsFor: 'navigation' stamp: 'sw 11/8/2002 21:30'!
goToPageMorph: aMorph
	"Set the given morph as the current page; run closing and opening scripts as appropriate"

	self goToPageMorph: aMorph runTransitionScripts: true! !

!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: 'sw 11/8/2002 13:34'!
goToPageMorph: aMorph runTransitionScripts: aBoolean
	"Set the given morph as the current page.  If the boolean parameter is true, then opening and closing scripts will be run"

	self goToPage: (pages identityIndexOf: aMorph ifAbsent: [^ self "abort"]) transitionSpec: nil runTransitionScripts: aBoolean
! !

!BookMorph methodsFor: 'navigation' stamp: 'dgd 2/22/2003 18:49'!
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 isNil or: [newPage == currentPage]) 
				ifTrue: [nil]
				ifFalse: [oldPageIndex < pageIndex].
	tSpec := transitionSpec ifNil: 
					["If transition not specified by requestor..."

					newPage valueOfProperty: #transitionSpec
						ifAbsent: 
							[" ... then consult new page"

							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 notNil 
		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: 'dgd 2/22/2003 18:49'!
goToPageMorph: newPage transitionSpec: transitionSpec runTransitionScripts: aBoolean 
	"Install the given page as the new current page; use the given transition spec, and if the boolean parameter is true, run closing and opening scripts on the outgoing and incoming players"

	| 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 isNil or: [newPage == currentPage]) 
				ifTrue: [nil]
				ifFalse: [oldPageIndex < pageIndex].
	tSpec := transitionSpec ifNil: 
					["If transition not specified by requestor..."

					newPage valueOfProperty: #transitionSpec
						ifAbsent: 
							[" ... then consult new page"

							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 notNil 
		ifTrue: 
			[(((pages at: pageIndex) owner isKindOf: TransitionMorph) 
				and: [(pages at: pageIndex) isInWorld]) 
					ifTrue: [^self	"In the process of a prior pageTurn"].
			aBoolean 
				ifTrue: [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].
								aBoolean 
									ifTrue: [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: 'dgd 2/21/2003 23:10'!
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 first]].
	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: 'dgd 2/21/2003 23:11'!
nextPage
	currentPage isNil 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: 'dgd 2/21/2003 23:11'!
previousPage
	currentPage isNil 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: 'other' stamp: 'sw 6/6/2003 13:55'!
adjustCurrentPageForFullScreen
	"Adjust current page to conform to whether or not I am in full-screen mode.  Also, enforce uniform page size constraint if appropriate"

	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].
			self uniformPageSize ifNotNilDo:
				[:anExtent | currentPage extent: anExtent]].
	(self valueOfProperty: #floatingPageControls) ifNotNilDo:
		[:pc | pc isInWorld ifFalse: [pc openInWorld]]! !

!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: 'tk 2/19/2001 18:35'!
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 label: ' < ' ; actionSelector: #previousPage).
		"copy 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.
	aButton _ SimpleButtonMorph new target: self; borderColor: Color black; 
				color: aColor; borderWidth: 0.
	aRow addMorphBack: (but _ aButton 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: 'sw 10/1/1998 13:40'!
resizePagesTo: anExtent
	pages do:
		[:aPage | aPage extent: anExtent]! !

!BookMorph methodsFor: 'other' stamp: 'sw 6/6/2003 17:21'!
setExtentFromHalo: anExtent
	"The user has dragged the grow box such that the receiver's extent would be anExtent.  Do what's needed.  For a BookMorph, we assume any resizing attempt is a request that the book-page currently being viewed be resized accoringly; this will typically not affect unseen book pages, though there is a command that can be issued to harmonize all book-page sizes, and also an option to set that will maintain all pages at the same size no matter what."

	currentPage isInWorld
		ifFalse: "doubtful case mostly"
			[super setExtentFromHalo: anExtent]
		ifTrue:
			[currentPage width: anExtent x.
			currentPage height: (anExtent y - (self innerBounds height - currentPage height)).
			self maintainsUniformPageSize ifTrue:
				[self setProperty: #uniformPageSize toValue: currentPage extent]]! !


!BookMorph methodsFor: 'Postscript Canvases'!
asPostscript
	^self asPostscriptPrintJob.
! !

!BookMorph methodsFor: 'Postscript Canvases' stamp: 'mpw 9/13/1999 20:22'!
fullDrawPostscriptOn:aCanvas
	^aCanvas fullDrawBookMorph:self.
! !


!BookMorph methodsFor: 'parts bin' stamp: 'sw 8/2/2001 16:52'!
initializeToStandAlone
	self initialize.
	self removeEverything; pageSize: 360@228; color: (Color gray: 0.9).
	self borderWidth: 1; borderColor: Color black.
	self beSticky.
	self showPageControls; insertPage.
	^ self! !


!BookMorph methodsFor: 'printing' stamp: 'RAA 2/1/2001 17:41'!
pagesHandledAutomatically

	^true! !


!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 methodsFor: 'sorting' stamp: 'ar 4/10/2005 18:42'!
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 isString 
				ifTrue: 
					["a url"

					toAdd := pages detect: [:aPage | aPage url = toAdd] ifNone: [toAdd]].
			toAdd isString 
				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 isEmpty ifTrue: [self insertPage].
	rejects notEmpty 
		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 12:12'!
sortPages: evt

	^ self sortPages! !


!BookMorph methodsFor: 'submorphs-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: 'submorphs-add/remove' 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: 'uniform page size' stamp: 'sw 3/3/2004 18:39'!
keepingUniformPageSizeString
	"Answer a string characterizing whether I am currently maintaining uniform page size"

	^ (self maintainsUniformPageSize
		ifTrue: ['<yes>']
		ifFalse: ['<no>']), 'keep all pages the same size' translated! !

!BookMorph methodsFor: 'uniform page size' stamp: 'sw 6/6/2003 13:56'!
maintainsUniformPageSize
	"Answer whether I am currently set up to maintain uniform page size"

	^ self uniformPageSize notNil! !

!BookMorph methodsFor: 'uniform page size' stamp: 'sw 6/6/2003 13:56'!
maintainsUniformPageSize: aBoolean
	"Set the property governing whether I maintain uniform page size"

	aBoolean
		ifFalse:
			[self removeProperty: #uniformPageSize]
		ifTrue:
			[self setProperty: #uniformPageSize toValue: currentPage extent]! !

!BookMorph methodsFor: 'uniform page size' stamp: 'sw 6/6/2003 13:57'!
toggleMaintainUniformPageSize
	"Toggle whether or not the receiver should maintain uniform page size"

	self maintainsUniformPageSize: self maintainsUniformPageSize not! !

!BookMorph methodsFor: 'uniform page size' stamp: 'sw 6/6/2003 13:57'!
uniformPageSize
	"Answer the uniform page size to maintain, or nil if the option is not set"

	^ self valueOfProperty: #uniformPageSize ifAbsent: [nil]! !


!BookMorph methodsFor: '*eToys-e-toy support' stamp: 'sw 10/2/97 15:22'!
configureForKids
	super configureForKids.
	pages do:
		[:aPage | aPage configureForKids].! !

!BookMorph methodsFor: '*eToys-e-toy support' 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 class
	instanceVariableNames: ''!

!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! !


!BookMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:31'!
initialize

	FileList registerFileReader: self.

	self registerInFlapsRegistry.	! !

!BookMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:37'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(BookMorph		nextPageButton			'NextPage'		'A button that takes you to the next page')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(BookMorph	previousPageButton 		'PreviousPage'	'A button that takes you to the previous page')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(BookMorph	authoringPrototype		'Book'			'A multi-paged structure')
						forFlapNamed: 'PlugIn Supplies'.
						cl registerQuad: #(BookMorph		nextPageButton			'NextPage'		'A button that takes you to the next page')
						forFlapNamed: 'Supplies'.
						cl registerQuad: #(BookMorph	previousPageButton 		'PreviousPage'	'A button that takes you to the previous page')
						forFlapNamed: 'Supplies'.
						cl registerQuad: #(BookMorph	authoringPrototype		'Book'			'A multi-paged structure')
						forFlapNamed: 'Supplies']! !


!BookMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:28'!
fileReaderServicesForFile: fullName suffix: suffix

	^(suffix = 'bo') | (suffix = '*') 
		ifTrue: [ Array with: self serviceLoadAsBook]
		ifFalse: [#()]
! !

!BookMorph class methodsFor: 'fileIn/Out' stamp: 'LEG 10/25/2001 00:06'!
openFromFile: fullName
	"Reconstitute a Morph from the selected file, presumed to be represent
	a Morph saved via the SmartRefStream mechanism, and open it in an
	appropriate Morphic world"

	| book aFileStream |
	Smalltalk verifyMorphicAvailability ifFalse: [^ self].

	aFileStream _ FileStream oldFileNamed: fullName.
	book _ BookMorph new.
	book setProperty: #url toValue: aFileStream url.
	book fromRemoteStream: aFileStream.
	aFileStream close.

	Smalltalk isMorphic 
		ifTrue: [ActiveWorld addMorphsAndModel: book]
		ifFalse:
			[book isMorph ifFalse: [^self inform: 'Can only load a single morph
into an mvc project via this mechanism.'].
			book openInWorld].
	book goToPage: 1! !

!BookMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 21:33'!
serviceLoadAsBook

	^ SimpleServiceEntry 
			provider: self 
			label: 'load as book'
			selector: #openFromFile:
			description: 'open as bookmorph'! !

!BookMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 21:33'!
services

	^ Array with: self serviceLoadAsBook! !


!BookMorph class methodsFor: 'initialize-release' stamp: 'asm 4/11/2003 12:31'!
unload
	"Unload the receiver from global registries"

	self environment
		at: #FileList
		ifPresent: [:cl | cl unregisterFileReader: self].
	self environment
		at: #Flaps
		ifPresent: [:cl | cl unregisterQuadsWithReceiver: self]! !


!BookMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:20'!
descriptionForPartsBin
	^ self partName:	'Book'
		categories:		#('Presentation')
		documentation:	'Multi-page structures'! !


!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: 'scripting' stamp: 'sw 6/13/2001 17:14'!
nextPageButton
	"Answer a button that will take the user to the next page of its enclosing book"

	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton target: aButton; actionSelector: #nextOwnerPage; label: '->'; color: Color yellow.
	aButton setNameTo: 'next'.
	^ aButton! !

!BookMorph class methodsFor: 'scripting' stamp: 'sw 6/13/2001 17:13'!
previousPageButton
	"Answer a button that will take the user to the previous page of its enclosing book"

	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton target: aButton; actionSelector: #previousOwnerPage; color: Color yellow; label: '<-'.
	aButton setNameTo: 'previous'.
	^ aButton! !


!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: '*eToys-scripting' stamp: 'sw 11/7/2002 13:20'!
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')
			(slot pageNumber 'The ordinal number of the current page' Number readWrite Player getPageNumber Player setPageNumber:))))! !
AlignmentMorph subclass: #BookPageSorterMorph
	instanceVariableNames: 'book pageHolder'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Books'!

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'jm 6/17/1998 21:27'!
acceptSort

	book acceptSortedContentsFrom: pageHolder.
	self delete.
! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/26/2003 13:21'!
addControls

	| bb r aButton str |
	r _ AlignmentMorph newRow color: Color transparent; borderWidth: 0; layoutInset: 0.
	r wrapCentering: #center; cellPositioning: #topCenter; 
			hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (self wrapperFor: (bb label: 'Okay' translated;	actionSelector: #acceptSort)).
	bb _ SimpleButtonMorph new target: self; borderColor: Color black.
	r addMorphBack: (self wrapperFor: (bb label: 'Cancel' translated;	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' translated.
	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: 'dgd 2/17/2003 19:56'!
changeExtent: aPoint 
	self extent: aPoint.
	pageHolder extent: self extent - self borderWidth! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/26/2003 13:22'!
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 label: 'Close' translated; 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: 'RAA 6/28/2000 11:57'!
getPartsBinStatus

	^pageHolder isPartsBin! !

!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: 'RAA 6/28/2000 12:10'!
wrapperFor: aMorph

	^self columnWith: (self rowWith: aMorph)
! !


!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: 'dropping/grabbing' 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: 'initialization' stamp: 'dgd 2/17/2003 19:55'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 2! !

!BookPageSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:55'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color lightGray! !

!BookPageSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:56'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	self extent: Display extent - 100;
		 listDirection: #topToBottom;
		 wrapCentering: #topLeft;
		 hResizing: #shrinkWrap;
		 vResizing: #shrinkWrap;
		 layoutInset: 3.
	pageHolder _ PasteUpMorph new behaveLikeHolder extent: self extent -self borderWidth.
	pageHolder hResizing: #shrinkWrap.
	"pageHolder cursor: 0."
	"causes a walkback as of 5/25/2000"
	self addControls.
	self addMorphBack: pageHolder! !
SketchMorph subclass: #BookPageThumbnailMorph
	instanceVariableNames: 'page pageNumber bookMorph flipOnClick'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-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: '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 1/4/1999 12:52'!
inBook: book
	bookMorph _ book! !

!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: '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: '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! !


!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: 'event handling' stamp: 'di 1/4/1999 12:19'!
handlesMouseDown: event

	^ event shiftPressed or: [flipOnClick and: [event controlKeyPressed not]]! !

!BookPageThumbnailMorph methodsFor: 'event handling' stamp: 'tk 7/25/2001 18:09'!
mouseDown: event
	"turn the book to that page"

	"May need to lie to it so mouseUp won't go to menu that may come up during fetch of a page in doPageFlip.  (Is this really true? --tk)"

	self doPageFlip.
! !


!BookPageThumbnailMorph methodsFor: 'fileIn/Out' stamp: 'ar 4/10/2005 18:45'!
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 isString) & (page isString) ifTrue: [
		^ super objectForDataStream: refStrm].
	(bookMorph isNil) & (page isString) ifTrue: [
		^ super objectForDataStream: refStrm].
	(bookMorph isNil) & (page url notNil) ifTrue: [
		^ super objectForDataStream: refStrm].
	(bookMorph isNil) & (page url isNil) ifTrue: [
		self error: 'page should already have a url' translated.
		"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: 'ar 4/10/2005 18:45'!
objectsInMemory
	"See if page or bookMorph need to be brought in from a server."
	| bookUrl bk wld try |
	bookMorph ifNil: ["fetch the page"
		page isString ifFalse: [^ self].	"a morph"
		try _ (SqueakPageCache atURL: page) fetchContents.
		try ifNotNil: [page _ try].
		^ self].
	bookMorph isString 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' translated].
		bk == #out ifTrue: [
			(bk _ BookMorph new fromURL: bookUrl) ifNil: [^ self]].
		bookMorph _ bk].
	page isString ifTrue: [
		page _ (bookMorph pages detect: [:pg | pg url = page] 
					ifNone: [bookMorph pages first])].
! !


!BookPageThumbnailMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'!
defaultColor
	"answer the default color/fill style for the receiver"
	^ Color lightGray! !

!BookPageThumbnailMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:53'!
initialize
	"initialize the state of the receiver"
	| f |
	super initialize.
	""
	flipOnClick _ false.
	
	f _ Form extent: 60 @ 80 depth: Display depth.
	f fill: f boundingBox fillColor: color.
	self form: f! !


!BookPageThumbnailMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:57'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'make a flex morph' translated selector: #makeFlexMorphFor: argument: aHandMorph.
	flipOnClick
		ifTrue: [aCustomMenu add: 'disable bookmark action' translated action: #toggleBookmark]
		ifFalse: [aCustomMenu add: 'enable bookmark action' translated action: #toggleBookmark].
	(bookMorph isKindOf: BookMorph)
		ifTrue:
			[aCustomMenu add: 'set page sound' translated action: #setPageSound:.
			aCustomMenu add: 'set page visual' translated action: #setPageVisual:]
! !


!BookPageThumbnailMorph methodsFor: '*sound-piano rolls' 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]! !
AlignmentMorph subclass: #BooklikeMorph
	instanceVariableNames: 'pageSize newPagePrototype'
	classVariableNames: 'PageFlipSoundOn'
	poolDictionaries: ''
	category: 'MorphicExtras-Books'!
!BooklikeMorph commentStamp: '<historical>' prior: 0!
A common superclass for BookMorph and WebBookMorph!


!BooklikeMorph methodsFor: 'e-toy support' 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: '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: 'menus' 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: 'misc' stamp: 'dgd 8/30/2003 21:13'!
addBookMenuItemsTo: aCustomMenu hand: aHandMorph
	(self hasSubmorphWithProperty: #pageControl)
		ifTrue: [aCustomMenu add: 'hide page controls' translated action: #hidePageControls]
		ifFalse: [aCustomMenu add: 'show page controls' translated action: #showPageControls]! !

!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: 'gk 2/24/2004 08:27'!
playPageFlipSound: soundName
	self presenter ifNil: [^ self].  "Avoid failures when called too early"
	PageFlipSoundOn  "mechanism to suppress sounds at init time"
			ifTrue: [self playSoundNamed: soundName].
! !

!BooklikeMorph methodsFor: 'misc' stamp: 'dgd 9/19/2003 11:04'!
showingFullScreenString
	^ (self isInFullScreenMode
		ifTrue: ['exit full screen']
		ifFalse: ['show full screen']) translated! !

!BooklikeMorph methodsFor: 'misc' stamp: 'dgd 9/19/2003 11:04'!
showingPageControlsString
	^ (self pageControlsVisible
		ifTrue: ['hide page controls']
		ifFalse: ['show page controls']) translated! !


!BooklikeMorph methodsFor: 'page controls' stamp: 'sw 6/6/2003 14:10'!
addPageControlMorph: aMorph
	"Add the morph provided as a page control, at the appropriate place"

	aMorph setProperty: #pageControl toValue: true.
	self addMorph: aMorph asElementNumber: self indexForPageControls! !

!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: 'yo 1/14/2005 19:25'!
fullControlSpecs

	^ {
		#spacer.
		#variableSpacer.
		{'-'.		#deletePage.				'Delete this page' translated}.
		#spacer.
		{'«'.		#firstPage.				'First page' translated}.
		#spacer.
		{'<'. 		#previousPage.			'Previous page' translated}.
		#spacer.
		{'·'.		#invokeBookMenu. 		'Click here to get a menu of options for this book.' translated}.
		#spacer.
		{'>'.		#nextPage.				'Next page' translated}.
		#spacer.
		{ '»'.		#lastPage.				'Final page' translated}.
		#spacer.
		{'+'.		#insertPage.				'Add a new page after this one' translated}.
		#variableSpacer.
		{'³'.		#fewerPageControls.	'Fewer controls' translated}
}
! !

!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: 'sw 6/6/2003 17:00'!
indexForPageControls
	"Answer which submorph should hold the page controls"

	^ (submorphs size > 0 and: [submorphs first hasProperty: #header])
		ifTrue:	[2]
		ifFalse:	[1]! !

!BooklikeMorph methodsFor: 'page controls' stamp: 'tk 2/19/2001 18:34'!
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 col row b lastGuy |
	c _ (color saturation > 0.1) ifTrue: [color slightlyLighter] ifFalse: [color slightlyDarker].
	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 _ SimpleButtonMorph new target: self; borderWidth: 1; 
								borderColor: Color veryLightGray; color: c.
						b 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 6/6/2003 22:44'!
setEventHandlerForPageControls: controls
	"Set the controls' event handler if appropriate.  Default is to let the tool be dragged by the controls"

	controls eventHandler: (EventHandler new on: #mouseDown send: #move to: self)! !

!BooklikeMorph methodsFor: 'page controls' stamp: 'dgd 9/19/2003 11:35'!
shortControlSpecs
^ {
		#spacer.
		#variableSpacer.
		{'<'. 		#previousPage.			'Previous page' translated}.
		#spacer.
		{'·'.		#invokeBookMenu. 		'Click here to get a menu of options for this book.' translated}.
		#spacer.
		{'>'.		#nextPage.				'Next page' translated}.
		#spacer.
		#variableSpacer.
		{'³'.		#showMoreControls.		'More controls' translated}
}
! !

!BooklikeMorph methodsFor: 'page controls' stamp: 'sw 3/2/1999 15:01'!
showPageControls
	self showPageControls: self shortControlSpecs! !

!BooklikeMorph methodsFor: 'page controls' stamp: 'sw 6/6/2003 13:58'!
showPageControls: controlSpecs  
	"Remove any existing page controls, and add fresh controls at the top of the receiver (or in position 2 if the receiver's first submorph is one with property #header).  Add a single column of controls."

	| pageControls column |
	self hidePageControls.
	column _ AlignmentMorph newColumn beTransparent.
	pageControls _ self makePageControlsFrom: controlSpecs.
	pageControls borderWidth: 0; layoutInset: 4.
	pageControls beSticky.
	pageControls setNameTo: 'Page Controls'.
	self setEventHandlerForPageControls: pageControls.
	column addMorphBack: pageControls.
	self addPageControlMorph: column! !

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

BooklikeMorph class
	instanceVariableNames: ''!

!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! !


!BooklikeMorph class methodsFor: 'class initialization' stamp: 'sw 7/4/1998 15:59'!
initialize
	"BooklikeMorph initialize"
	PageFlipSoundOn _ true
! !
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: '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' stamp: 'zz 3/2/2004 23:44'!
and: block1 and: block2
	"Nonevaluating conjunction without deep nesting.
	The receiver is evaluated, followed by the blocks in order.
	If any of these evaluates as false, then return false immediately,
		without evaluating any further blocks.
	If all return true, then return true."

	self ifFalse: [^ false].
	block1 value ifFalse: [^ false].
	block2 value ifFalse: [^ false].
	^ true! !

!Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44'!
and: block1 and: block2 and: block3
	"Nonevaluating conjunction without deep nesting.
	The receiver is evaluated, followed by the blocks in order.
	If any of these evaluates as false, then return false immediately,
		without evaluating any further blocks.
	If all return true, then return true."

	self ifFalse: [^ false].
	block1 value ifFalse: [^ false].
	block2 value ifFalse: [^ false].
	block3 value ifFalse: [^ false].
	^ true! !

!Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44'!
and: block1 and: block2 and: block3 and: block4
	"Nonevaluating conjunction without deep nesting.
	The receiver is evaluated, followed by the blocks in order.
	If any of these evaluates as false, then return false immediately,
		without evaluating any further blocks.
	If all return true, then return true."

	self ifFalse: [^ false].
	block1 value ifFalse: [^ false].
	block2 value ifFalse: [^ false].
	block3 value ifFalse: [^ false].
	block4 value ifFalse: [^ false].
	^ true! !

!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: 'controlling' stamp: 'zz 3/2/2004 23:45'!
or: block1 or: block2
	"Nonevaluating alternation without deep nesting.
	The receiver is evaluated, followed by the blocks in order.
	If any of these evaluates as true, then return true immediately,
		without evaluating any further blocks.
	If all return false, then return false."

	self ifTrue: [^ true].
	block1 value ifTrue: [^ true].
	block2 value ifTrue: [^ true].
	^ false! !

!Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45'!
or: block1 or: block2 or: block3
	"Nonevaluating alternation without deep nesting.
	The receiver is evaluated, followed by the blocks in order.
	If any of these evaluates as true, then return true immediately,
		without evaluating any further blocks.
	If all return false, then return false."

	self ifTrue: [^ true].
	block1 value ifTrue: [^ true].
	block2 value ifTrue: [^ true].
	block3 value ifTrue: [^ true].
	^ false! !

!Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45'!
or: block1 or: block2 or: block3 or: block4
	"Nonevaluating alternation without deep nesting.
	The receiver is evaluated, followed by the blocks in order.
	If any of these evaluates as true, then return true immediately,
		without evaluating any further blocks.
	If all return false, then return false."

	self ifTrue: [^ true].
	block1 value ifTrue: [^ true].
	block2 value ifTrue: [^ true].
	block3 value ifTrue: [^ true].
	block4 value ifTrue: [^ true].
	^ false! !

!Boolean methodsFor: 'controlling' stamp: 'dgd 9/26/2004 19:05'!
or: block1 or: block2 or: block3 or: block4 or: block5
	"Nonevaluating alternation without deep nesting.
	The receiver is evaluated, followed by the blocks in order.
	If any of these evaluates as true, then return true immediately,
		without evaluating any further blocks.
	If all return false, then return false."

	self ifTrue: [^ true].
	block1 value ifTrue: [^ true].
	block2 value ifTrue: [^ true].
	block3 value ifTrue: [^ true].
	block4 value ifTrue: [^ true].
	block5 value ifTrue: [^ true].
	^ false! !


!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: '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' stamp: 'PH 10/3/2003 08:10'!
==> aBlock
	"this is material implication, a ==> b, also known as:
			b if a 
			a implies b
			if a then b
			b is a consequence of a
			a therefore b (but note: 'it is raining therefore it is cloudy' is implication; 'it is autumn therefore the leaves are falling' is equivalence).
		
	Here is the truth table for material implication (view in a monospaced font):
	
	   p   |   q   |   p ==> q
	-------|-------|-------------
	   T   |   T   |      T
	   T   |   F   |      F
	   F   |   T   |      T
	   F   |   F   |      T
	"

	^self not or: [aBlock value]! !

!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: 'printing' stamp: 'sw 9/27/2001 17:19'!
basicType
	"Answer a symbol representing the inherent type of the receiver"

	^ #Boolean! !

!Boolean methodsFor: 'printing' stamp: 'apb 4/21/2006 09:22'!
isLiteral 
	^ true! !

!Boolean methodsFor: 'printing'!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:."

	self printOn: aStream! !


!Boolean methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:45'!
isSelfEvaluating
	^ true! !


!Boolean methodsFor: '*eToys-*morphic' 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! !
PreferenceView subclass: #BooleanPreferenceView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!BooleanPreferenceView commentStamp: '<historical>' prior: 0!
I am responsible for building the visual representation of a preference that accepts true and false values!


!BooleanPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/24/2004 22:36'!
offerPreferenceNameMenu: aPanel with: ignored1 in: ignored2
	"the user clicked on a preference name -- put up a menu"

	| aMenu |
	ActiveHand showTemporaryCursor: nil.
	aMenu := MenuMorph new defaultTarget: self preference.
	aMenu addTitle: self preference name.

	(Preferences okayToChangeProjectLocalnessOf: self preference name) ifTrue:
		[aMenu addUpdating: #isProjectLocalString target: self preference action: #toggleProjectLocalness.
		aMenu balloonTextForLastItem: 'Some preferences are best applied uniformly to all projects, and others are best set by each individual project.  If this item is checked, then this preference will be printed in bold and will have a separate value for each project'].

	aMenu add: 'browse senders' target: self systemNavigation selector: #browseAllCallsOn: argument: self preference name.
	aMenu balloonTextForLastItem: 'This will open a method-list browser on all methods that the send the preference "', self preference name, '".'. 
	aMenu add: 'show category...' target: aPanel selector: #findCategoryFromPreference: argument: self preference name.
	aMenu balloonTextForLastItem: 'Allows you to find out which category, or categories, this preference belongs to.'.

	Smalltalk isMorphic ifTrue:
		[aMenu add: 'hand me a button for this preference' target: self selector: #tearOffButton.
		aMenu balloonTextForLastItem: 'Will give you a button that governs this preference, which you may deposit wherever you wish'].

	aMenu add: 'copy this name to clipboard' target: self preference selector: #copyName.
	aMenu balloonTextForLastItem: 'Copy the name of the preference to the text clipboard, so that you can paste into code somewhere'.

	aMenu popUpInWorld! !

!BooleanPreferenceView methodsFor: 'user interface' stamp: 'md 9/5/2005 15:40'!
representativeButtonWithColor: aColor inPanel: aPreferencesPanel
	"Return a button that controls the setting of prefSymbol.  It will keep up to date even if the preference value is changed in a different place"

	| outerButton aButton str miniWrapper |
	
	outerButton := AlignmentMorph newRow height: 24.
	outerButton color:  (aColor ifNil: [Color r: 0.645 g: 1.0 b: 1.0]).
	outerButton hResizing: (aPreferencesPanel ifNil: [#shrinkWrap] ifNotNil: [#spaceFill]).
	outerButton vResizing: #shrinkWrap.
	outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox).
	aButton
		target: self preference;
		actionSelector: #togglePreferenceValue;
		getSelector: #preferenceValue.

	outerButton addTransparentSpacerOfSize: (2 @ 0).
	str := StringMorph contents: self preference name font: (StrikeFont familyName: 'NewYork' size: 12).

	self preference localToProject ifTrue:
		[str emphasis: TextEmphasis bold emphasisCode].

	miniWrapper := AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	miniWrapper beTransparent addMorphBack: str lock.
	aPreferencesPanel
		ifNotNil:  "We're in a Preferences panel"
			[miniWrapper on: #mouseDown send: #offerPreferenceNameMenu:with:in: to: self withValue: aPreferencesPanel.
			miniWrapper on: #mouseEnter send: #menuButtonMouseEnter: to: miniWrapper.
			miniWrapper on: #mouseLeave send: #menuButtonMouseLeave: to: miniWrapper.
			miniWrapper setBalloonText: 'Click here for a menu of options regarding this preference.  Click on the checkbox to the left to toggle the setting of this preference']

		ifNil:  "We're a naked button, not in a panel"
			[miniWrapper setBalloonText: self preference helpString; setProperty: #balloonTarget toValue: aButton].

	outerButton addMorphBack: miniWrapper.
	outerButton setNameTo: self preference name.

	aButton setBalloonText: self preference helpString.

	^ outerButton

	"(Preferences preferenceAt: #balloonHelpEnabled) view tearOffButton"! !

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

BooleanPreferenceView class
	instanceVariableNames: ''!

!BooleanPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 15:55'!
initialize
	PreferenceViewRegistry ofBooleanPreferences register: self.! !

!BooleanPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 15:55'!
unload
	PreferenceViewRegistry ofBooleanPreferences unregister: self.! !


!BooleanPreferenceView class methodsFor: 'view registry' stamp: 'hpt 9/26/2004 16:10'!
handlesPanel: aPreferencePanel
	^aPreferencePanel isKindOf: PreferencesPanel! !
ScriptEditorMorph subclass: #BooleanScriptEditor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Support'!
!BooleanScriptEditor commentStamp: '<historical>' prior: 0!
A ScriptEditor required to hold a Boolean!


!BooleanScriptEditor methodsFor: 'dropping/grabbing' stamp: 'sw 3/15/2005 22:43'!
wantsDroppedMorph: aMorph event: evt 
	"Answer whether the receiver would be interested in accepting the morph"

	(submorphs detect: [:m | m isAlignmentMorph] ifNone: [nil]) 
		ifNotNil: [^ false].

	((aMorph isKindOf: ParameterTile) and: [aMorph scriptEditor == self topEditor])
		ifTrue: [^ true].
	^ (aMorph isKindOf: PhraseTileMorph orOf: WatcherWrapper) 
		and: [(#(#Command #Unknown) includes: aMorph resultType capitalized) not]! !


!BooleanScriptEditor methodsFor: 'other' stamp: 'tk 3/1/2001 11:24'!
hibernate 
	"do nothing"! !

!BooleanScriptEditor methodsFor: 'other' stamp: 'dgd 2/22/2003 14:44'!
storeCodeOn: aStream indent: tabCount 
	(submorphs notEmpty and: [submorphs first submorphs notEmpty]) 
		ifTrue: 
			[aStream nextPutAll: '(('.
			super storeCodeOn: aStream indent: tabCount.
			aStream nextPutAll: ') ~~ false)'.
			^self].
	aStream nextPutAll: ' true '! !

!BooleanScriptEditor methodsFor: 'other' stamp: 'tk 2/28/2001 21:07'!
unhibernate 
	"do nothing"! !
ClassTestCase subclass: #BooleanTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'KernelTests-Objects'!
!BooleanTest commentStamp: '<historical>' prior: 0!
This is the unit test for the class Boolean. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: 
	- http://www.c2.com/cgi/wiki?UnitTest
	- http://minnow.cc.gatech.edu/squeak/1547
	- the sunit class category
!


!BooleanTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:00'!
testBasicType
	
	self assert: (true basicType = #Boolean).
	self assert: (false basicType = #Boolean).! !

!BooleanTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:02'!
testBooleanInitializedInstance

	self assert: (Boolean initializedInstance = nil).! !

!BooleanTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:02'!
testBooleanNew

	self should: [Boolean new] raise: TestResult error. 
	self should: [True new] raise: TestResult error. 
	self should: [False new] raise: TestResult error. ! !

!BooleanTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:02'!
testNew

	self should: [Boolean new] raise: TestResult error. ! !

!BooleanTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:01'!
testNewTileMorphRepresentative

	self assert: (false newTileMorphRepresentative isKindOf: TileMorph).
	self assert: (false newTileMorphRepresentative literal = false).
	self assert: (true newTileMorphRepresentative literal = true).! !
TileMorph subclass: #BooleanTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'EToys-Scripting Tiles'!
!BooleanTile commentStamp: '<historical>' prior: 0!
A tile whose result type is boolean.!


!BooleanTile methodsFor: 'accessing' stamp: 'sw 9/27/2001 17:19'!
resultType
	"Answer the result type of the receiver"

	^ #Boolean! !
DataType subclass: #BooleanType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Protocols-Type Vocabularies'!
!BooleanType commentStamp: 'sw 1/5/2005 22:15' prior: 0!
A data type representing Boolean values, i.e., true or false.!


!BooleanType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:20'!
initialValueForASlotFor: aPlayer
	"Answer the value to give initially to a newly created slot of the given type in the given player"
	^ true! !


!BooleanType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:23'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	self vocabularyName: #Boolean! !


!BooleanType methodsFor: 'tiles' stamp: 'yo 2/18/2005 16:39'!
setFormatForDisplayer: aDisplayer
	"Set up the displayer to have the right format characteristics"

	aDisplayer useSymbolFormat.
	aDisplayer growable: true
! !


!BooleanType methodsFor: '*eToys-color' stamp: 'sw 9/27/2001 17:20'!
typeColor
	"Answer the color for tiles to be associated with objects of this type"

	^ self subduedColorFromTriplet: #(0.94 1.0 0.06)! !


!BooleanType methodsFor: '*eToys-tiles' stamp: 'sw 9/27/2001 17:20'!
defaultArgumentTile
	"Answer a tile to represent the type"

	^ true newTileMorphRepresentative typeColor: self typeColor! !
Object subclass: #BorderStyle
	instanceVariableNames: ''
	classVariableNames: 'Default'
	poolDictionaries: ''
	category: 'Morphic-Borders'!
!BorderStyle commentStamp: 'kfr 10/27/2003 10:19' prior: 0!
See BorderedMorph

BorderedMorh new borderStyle: (BorderStyle inset width: 2); openInWorld.!


!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'!
baseColor
	^Color transparent! !

!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'!
baseColor: aColor
	"Ignored"! !

!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'!
color
	^Color transparent! !

!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'!
color: aColor
	"Ignored"! !

!BorderStyle methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:22'!
colorsAtCorners
	^Array new: 4 withAll: self color! !

!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'!
dotOfSize: diameter forDirection: aDirection
	| form |
	form _ Form extent: diameter@diameter depth: Display depth.
	form getCanvas fillOval: form boundingBox color: self color.
	^form! !

!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'!
style
	^#none! !

!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'!
width
	^0! !

!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'!
width: aNumber
	"Ignored"! !

!BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:08'!
widthForRounding
	^self width! !


!BorderStyle methodsFor: 'color tracking' stamp: 'ar 8/25/2001 17:29'!
trackColorFrom: aMorph
	"If necessary, update our color to reflect a change in aMorphs color"! !


!BorderStyle methodsFor: 'comparing' stamp: 'ar 8/25/2001 18:38'!
= aBorderStyle
	^self species = aBorderStyle species
		and:[self style == aBorderStyle style
		and:[self width = aBorderStyle width
		and:[self color = aBorderStyle color]]].! !

!BorderStyle methodsFor: 'comparing' stamp: 'ar 8/25/2001 16:08'!
hash
	"hash is implemented because #= is implemented"
	^self species hash bitXor: (self width hash bitXor: self color hash)! !


!BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 17:01'!
drawLineFrom: startPoint to: stopPoint on: aCanvas
	^aCanvas line: startPoint to: stopPoint width: self width color: self color! !

!BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:24'!
frameOval: aRectangle on: aCanvas
	"Frame the given rectangle on aCanvas"
	aCanvas frameOval: aRectangle width: self width color: self color! !

!BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:57'!
framePolygon: vertices on: aCanvas
	"Frame the given rectangle on aCanvas"
	self framePolyline: vertices on: aCanvas.
	self drawLineFrom: vertices last to: vertices first on: aCanvas.! !

!BorderStyle methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:59'!
framePolyline: vertices on: aCanvas 
	"Frame the given rectangle on aCanvas"

	| prev next |
	prev := vertices first.
	2 to: vertices size
		do: 
			[:i | 
			next := vertices at: i.
			self 
				drawLineFrom: prev
				to: next
				on: aCanvas.
			prev := next]! !

!BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:24'!
frameRectangle: aRectangle on: aCanvas
	"Frame the given rectangle on aCanvas"
	aCanvas frameRectangle: aRectangle width: self width color: self color! !


!BorderStyle methodsFor: 'initialize' stamp: 'ar 8/25/2001 16:06'!
releaseCachedState
	"Release any associated cached state"! !


!BorderStyle methodsFor: 'testing' stamp: 'ar 8/25/2001 16:08'!
isBorderStyle
	^true! !

!BorderStyle methodsFor: 'testing' stamp: 'ar 8/26/2001 19:30'!
isComplex
	^false! !

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

BorderStyle class
	instanceVariableNames: ''!

!BorderStyle class methodsFor: 'instance creation' stamp: 'sw 11/26/2001 16:05'!
borderStyleChoices
	"Answer the superset of all supported borderStyle symbols"

	^ #(simple inset raised complexAltFramed complexAltInset complexAltRaised complexFramed complexInset complexRaised)! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'yo 7/2/2004 17:21'!
borderStyleForSymbol: sym
	"Answer a border style corresponding to the given symbol"

	| aSymbol |
	aSymbol _ sym == #none ifTrue: [#simple] ifFalse: [sym].
	^ self perform: aSymbol
"
	| aSymbol selector |
	aSymbol _ sym == #none ifTrue: [#simple] ifFalse: [sym].
	selector _ Vocabulary eToyVocabulary translationKeyFor: aSymbol.
	selector isNil ifTrue: [selector _ aSymbol].
	^ self perform: selector
"
! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 23:52'!
color: aColor width: aNumber
	^self width: aNumber color: aColor! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:01'!
complexAltFramed
	^ComplexBorder style: #complexAltFramed! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:01'!
complexAltInset
	^ComplexBorder style: #complexAltInset! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'!
complexAltRaised
	^ComplexBorder style: #complexAltRaised! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'!
complexFramed
	^ComplexBorder style: #complexFramed! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'!
complexInset
	^ComplexBorder style: #complexInset! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'!
complexRaised
	^ComplexBorder style: #complexRaised! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 17:26'!
default
	^Default ifNil:[Default _ self new]! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 14:59'!
inset
	^InsetBorder new! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 14:59'!
raised
	^RaisedBorder new! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'sw 11/27/2001 15:22'!
simple
	"Answer a simple border style"

	^ SimpleBorder new! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'rr 6/21/2005 13:50'!
thinGray
	^ self width: 1 color: Color gray! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:19'!
width: aNumber
	^self width: aNumber color: Color black! !

!BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:19'!
width: aNumber color: aColor
	^SimpleBorder new color: aColor; width: aNumber; yourself! !
Morph subclass: #BorderedMorph
	instanceVariableNames: 'borderWidth borderColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
!BorderedMorph commentStamp: 'kfr 10/27/2003 11:17' prior: 0!
BorderedMorph introduce borders to morph. Borders have the instanceVariables borderWidth and borderColor.
 
BorderedMorph new borderColor: Color red; borderWidth: 10; openInWorld.

BorderedMorph also have a varaity of border styles: simple, inset, raised, complexAltFramed, complexAltInset, complexAltRaised, complexFramed, complexInset, complexRaised.
These styles are set using the classes BorderStyle, SimpleBorder, RaisedBorder, InsetBorder and ComplexBorder.

BorderedMorph new borderStyle: (SimpleBorder width: 1 color: Color white); openInWorld.
BorderedMorph new borderStyle: (BorderStyle inset width: 2); openInWorld.


!


!BorderedMorph methodsFor: 'accessing' stamp: 'sw 8/6/97 14:34'!
borderColor
	^ borderColor! !

!BorderedMorph methodsFor: 'accessing' stamp: 'ar 8/17/2001 16:52'!
borderColor: colorOrSymbolOrNil
	self doesBevels ifFalse:[
		colorOrSymbolOrNil isColor ifFalse:[^self]].
	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: 'aoy 2/17/2003 01:19'!
borderStyle
	"Work around the borderWidth/borderColor pair"

	| style |
	borderColor ifNil: [^BorderStyle default].
	borderWidth isZero ifTrue: [^BorderStyle default].
	style := self valueOfProperty: #borderStyle ifAbsent: [BorderStyle default].
	(borderWidth = style width and: 
			["Hah!! Try understanding this..."

			borderColor == style style or: 
					["#raised/#inset etc"

					#simple == style style and: [borderColor = style color]]]) 
		ifFalse: 
			[style := borderColor isColor 
				ifTrue: [BorderStyle width: borderWidth color: borderColor]
				ifFalse: [(BorderStyle perform: borderColor) width: borderWidth	"argh."].
			self setProperty: #borderStyle toValue: style].
	^style trackColorFrom: self! !

!BorderedMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 22:42'!
borderStyle: aBorderStyle 
	"Work around the borderWidth/borderColor pair"

	aBorderStyle = self borderStyle ifTrue: [^self].
	"secure against invalid border styles"
	(self canDrawBorder: aBorderStyle) 
		ifFalse: 
			["Replace the suggested border with a simple one"

			^self borderStyle: (BorderStyle width: aBorderStyle width
						color: (aBorderStyle trackColorFrom: self) color)].
	aBorderStyle width = self borderStyle width ifFalse: [self changed].
	(aBorderStyle isNil or: [aBorderStyle == BorderStyle default]) 
		ifTrue: 
			[self removeProperty: #borderStyle.
			borderWidth := 0.
			^self changed].
	self setProperty: #borderStyle toValue: aBorderStyle.
	borderWidth := aBorderStyle width.
	borderColor := aBorderStyle style == #simple 
				ifTrue: [aBorderStyle color]
				ifFalse: [aBorderStyle style].
	self changed! !

!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: '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'!
useRoundedCorners
	self cornerStyle: #rounded! !

!BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:37'!
useSquareCorners
	self cornerStyle: #square! !


!BorderedMorph methodsFor: 'drawing' stamp: 'dgd 2/17/2003 19:57'!
areasRemainingToFill: aRectangle 
	(color isColor
			and: [color isTranslucent])
		ifTrue: [^ Array with: aRectangle].
	self wantsRoundedCorners
		ifTrue: [(self borderWidth > 0
					and: [self borderColor isColor
							and: [self borderColor isTranslucent]])
				ifTrue: [^ aRectangle
						areasOutside: (self innerBounds intersect: self boundsWithinCorners)]
				ifFalse: [^ aRectangle areasOutside: self boundsWithinCorners]]
		ifFalse: [(self borderWidth > 0
					and: [self borderColor isColor
							and: [self borderColor isTranslucent]])
				ifTrue: [^ aRectangle areasOutside: self innerBounds]
				ifFalse: [^ aRectangle areasOutside: self bounds]]! !


!BorderedMorph methodsFor: 'geometry' stamp: 'sw 5/18/2001 22:52'!
acquireBorderWidth: aBorderWidth
	"Gracefully acquire the new border width, keeping the interior area intact and not seeming to shift"

	| delta |
	(delta _ aBorderWidth- self borderWidth) == 0 ifTrue: [^ self].
	self bounds: ((self bounds origin - (delta @ delta)) corner: (self bounds corner + (delta @ delta))).
	self borderWidth: aBorderWidth.
	self layoutChanged! !

!BorderedMorph methodsFor: 'geometry' stamp: 'nk 4/5/2001 14:24'!
closestPointTo: aPoint
	"account for round corners. Still has a couple of glitches at upper left and right corners"
	| pt |
	pt _ self bounds pointNearestTo: aPoint.
	self wantsRoundedCorners ifFalse: [ ^pt ].
	self bounds corners with: (self bounds insetBy: 6) corners do: [ :out :in |
		(pt - out) abs < (6@6)
			ifTrue: [ ^(in + (Point r: 5.0 degrees: (pt - in) degrees)) asIntegerPoint ].
	].
	^pt.! !

!BorderedMorph methodsFor: 'geometry' stamp: 'nk 4/5/2001 14:23'!
intersectionWithLineSegmentFromCenterTo: aPoint
	"account for round corners. Still has a couple of glitches at upper left and right corners"
	| pt |
	pt _ super intersectionWithLineSegmentFromCenterTo: aPoint.
	self wantsRoundedCorners ifFalse: [ ^pt ].
	self bounds corners with: (self bounds insetBy: 6) corners do: [ :out :in |
		(pt - out) abs < (6@6)
			ifTrue: [ ^(in + (Point r: 5.0 degrees: (pt - in) degrees)) asIntegerPoint ].
	].
	^pt.! !


!BorderedMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:53'!
borderInitialize
	"initialize the receiver state related to border"
	borderColor_ self defaultBorderColor.
	borderWidth _ self defaultBorderWidth!
]style[(16 2 49 15 4 22 11 3 4 19)f2b,f2,f2c146044000,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2! !

!BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'!
defaultBorderColor
	"answer the default border color/fill style for the receiver"
	^ Color black! !

!BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'!
defaultBorderWidth
	"answer the default border width for the receiver"
	^ 2! !

!BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:07'!
initialize
	"initialize the state of the receiver"
	super initialize.
""
	self borderInitialize! !


!BorderedMorph methodsFor: 'lookenhancements' stamp: 'jmv 2/2/2006 13:35'!
addCornerGrips
	self
		addMorphBack: (TopLeftGripMorph new target: self).
	self
		addMorphBack: (TopRightGripMorph new target: self).
	self
		addMorphBack: (BottomLeftGripMorph new target: self).
	self
		addMorphBack: (BottomRightGripMorph new target: self)! !

!BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 21:30'!
addPaneHSplitterBetween: topMorph and: bottomMorphs

	| targetY minX maxX splitter |
	targetY _ topMorph layoutFrame bottomFraction.

	minX _ (bottomMorphs detectMin: [:each | each layoutFrame leftFraction]) layoutFrame leftFraction.
	maxX _ (bottomMorphs detectMax: [:each | each layoutFrame rightFraction]) layoutFrame rightFraction.
	splitter _ ProportionalSplitterMorph new beSplitsTopAndBottom; yourself.
	splitter layoutFrame: (LayoutFrame
		fractions: (minX @ targetY corner: maxX @ targetY)
		offsets: (((topMorph layoutFrame leftOffset ifNil: [0]) @ 0 corner: (topMorph layoutFrame rightOffset ifNil: [0]) @ 4) translateBy: 0 @ (topMorph layoutFrame bottomOffset ifNil: [0]))).

	self addMorphBack: splitter! !

!BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:23'!
addPaneSplitters
	| splitter remaining target targetX sameX minY maxY targetY sameY minX maxX |
	self removePaneSplitters.
	self removeCornerGrips.

	remaining _ submorphs reject: [:each | each layoutFrame rightFraction = 1].
	[remaining notEmpty] whileTrue:
		[target _ remaining first.
		targetX _ target layoutFrame rightFraction.
		sameX _ submorphs select: [:each | each layoutFrame rightFraction = targetX].
		minY _ (sameX detectMin: [:each | each layoutFrame topFraction]) layoutFrame topFraction.
		maxY _ (sameX detectMax: [:each | each layoutFrame bottomFraction]) layoutFrame bottomFraction.
		splitter _ ProportionalSplitterMorph new.
		splitter layoutFrame: (LayoutFrame
			fractions: (targetX @ minY corner: targetX @ maxY)
			offsets: ((0 @ (target layoutFrame topOffset ifNil: [0]) corner: 4 @ (target layoutFrame bottomOffset ifNil: [0])) translateBy: (target layoutFrame rightOffset ifNil: [0]) @ 0)).
		self addMorphBack: splitter.
		remaining _ remaining copyWithoutAll: sameX].

	remaining _ submorphs copy reject: [:each | each layoutFrame bottomFraction = 1].
	[remaining notEmpty]
		whileTrue: [target _ remaining first.
			targetY _ target layoutFrame bottomFraction.
			sameY _ submorphs select: [:each | each layoutFrame bottomFraction = targetY].
			minX _ (sameY detectMin: [:each | each layoutFrame leftFraction]) layoutFrame leftFraction.
			maxX _ (sameY detectMax: [:each | each layoutFrame rightFraction]) layoutFrame rightFraction.
			splitter _ ProportionalSplitterMorph new beSplitsTopAndBottom; yourself.
			splitter layoutFrame: (LayoutFrame
				fractions: (minX @ targetY corner: maxX @ targetY)
				offsets: (((target layoutFrame leftOffset ifNil: [0]) @ 0 corner: (target layoutFrame rightOffset ifNil: [0]) @ 4) translateBy: 0 @ (target layoutFrame bottomOffset ifNil: [0]))).
			self addMorphBack: splitter.
			remaining _ remaining copyWithoutAll: sameY].

	self linkSubmorphsToSplitters.
	self splitters do: [:each | each comeToFront].
! !

!BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 21:26'!
addPaneVSplitterBetween: leftMorph and: rightMorphs 

	| targetX minY maxY splitter |
	targetX _ leftMorph layoutFrame rightFraction.
	minY _ (rightMorphs detectMin: [:each | each layoutFrame topFraction]) layoutFrame topFraction.
	maxY _ (rightMorphs detectMax: [:each | each layoutFrame bottomFraction]) layoutFrame bottomFraction.
	
	splitter _ ProportionalSplitterMorph new.
	splitter layoutFrame: (LayoutFrame
		fractions: (targetX @ minY corner: targetX @ maxY)
		offsets: ((0 @ (leftMorph layoutFrame topOffset ifNil: [0]) corner: (4@ (leftMorph layoutFrame bottomOffset ifNil: [0]))) translateBy: (leftMorph layoutFrame rightOffset ifNil: [0]) @ 0)).

	self addMorphBack: splitter! !

!BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:16'!
linkSubmorphsToSplitters

	self splitters do:
		[:each |
		each splitsTopAndBottom
			ifTrue:
				[self submorphsDo:
					[:eachMorph |
					(eachMorph ~= each and: [eachMorph layoutFrame bottomFraction = each layoutFrame topFraction]) ifTrue: [each addLeftOrTop: eachMorph].
					(eachMorph ~= each and: [eachMorph layoutFrame topFraction = each layoutFrame bottomFraction]) ifTrue: [each addRightOrBottom: eachMorph]]]
			ifFalse:
				[self submorphsDo:
					[:eachMorph |
					(eachMorph ~= each and: [eachMorph layoutFrame rightFraction = each layoutFrame leftFraction]) ifTrue: [each addLeftOrTop: eachMorph].
					(eachMorph ~= each and: [eachMorph layoutFrame leftFraction = each layoutFrame rightFraction]) ifTrue: [each addRightOrBottom: eachMorph]]]]! !

!BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 00:03'!
removeCornerGrips

	| corners |
	corners _ self submorphsSatisfying: [:each | each isKindOf: CornerGripMorph].
	corners do: [:each | each delete]! !

!BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:28'!
removePaneSplitters

	self splitters do: [:each | each delete]! !

!BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:16'!
splitters

	^ self submorphsSatisfying: [:each | each isKindOf: ProportionalSplitterMorph]! !


!BorderedMorph methodsFor: 'menu' stamp: 'dgd 9/18/2004 19:16'!
addBorderStyleMenuItems: aMenu hand: aHandMorph
	"Add border-style menu items"

	| subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	"subMenu addTitle: 'border' translated."
	subMenu addStayUpItemSpecial.
	subMenu addList: 
		{{'border color...' translated. #changeBorderColor:}.
		{'border width...' translated. #changeBorderWidth:}}.
	subMenu addLine.
	BorderStyle borderStyleChoices do:
		[:sym | (self borderStyleForSymbol: sym)
			ifNotNil:
				[subMenu add: sym translated target: self selector: #setBorderStyle: argument: sym]].
	aMenu add: 'border style' translated subMenu: subMenu
! !

!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: 'em 3/24/2005 14:36'!
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 ifNotNilDo: [:halo | halo addHandles].
			self rememberCommand:
				(Command new cmdWording: 'border change' translated;
					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.' translated hand: evt hand.
	handle startStepping! !


!BorderedMorph methodsFor: '*flexibleVocabularies-scripting' stamp: 'nk 9/4/2004 11:47'!
understandsBorderVocabulary
	"Replace the 'isKindOf: BorderedMorph' so that (for instance) Connectors can have their border vocabulary visible in viewers."
	^true! !


!BorderedMorph methodsFor: '*MorphicExtras-initialization' stamp: 'dgd 2/14/2003 22:00'!
basicInitialize
	"Do basic generic initialization of the instance variables"
	super basicInitialize.
""
	self borderInitialize! !


!BorderedMorph methodsFor: '*MorphicExtras-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.! !
StringMorph subclass: #BorderedStringMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-Widgets'!

!BorderedStringMorph methodsFor: 'accessing' stamp: 'ar 12/12/2001 03:03'!
measureContents
	^super measureContents +2.! !


!BorderedStringMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:34'!
drawOn: aCanvas
	| nameForm |
	font _ self fontToUse.
	nameForm _ Form extent: bounds extent depth: 8.
	nameForm getCanvas drawString: contents at: 0@0 font: self fontToUse color: Color black.
	(bounds origin + 1) eightNeighbors do: [ :pt |
		aCanvas
			stencil: nameForm 
			at: pt
			color: self borderColor.
	].
	aCanvas
		stencil: nameForm 
		at: bounds origin + 1 
		color: color.


	
! !


!BorderedStringMorph methodsFor: 'initialization' stamp: 'ar 12/14/2001 20:02'!
initWithContents: aString font: aFont emphasis: emphasisCode
	super initWithContents: aString font: aFont emphasis: emphasisCode.
	self borderStyle: (SimpleBorder width: 1 color: Color white).! !

!BorderedStringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42'!
initialize
"initialize the state of the receiver"
	super initialize.
""
	self
		borderStyle: (SimpleBorder width: 1 color: Color white)! !
BorderedMorph subclass: #BorderedSubpaneDividerMorph
	instanceVariableNames: 'resizingEdge'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'!
firstEnter: evt
	"The first time this divider is activated, find its window and redirect further interaction there."
	| window |

	window := self firstOwnerSuchThat: [:m | m respondsTo: #secondaryPaneTransition:divider:].
	window ifNil: [ self suspendEventHandler. ^ self ]. "not working out"
	window secondaryPaneTransition: evt divider: self.
	self on: #mouseEnter send: #secondaryPaneTransition:divider: to: window.
! !

!BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'!
horizontal

	self hResizing: #spaceFill.! !

!BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'!
resizingEdge

	^resizingEdge
! !

!BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'!
resizingEdge: edgeSymbol

	(#(top bottom) includes: edgeSymbol) ifFalse:
		[ self error: 'resizingEdge must be #top or #bottom' ].
	resizingEdge := edgeSymbol.
	self on: #mouseEnter send: #firstEnter: to: self.
! !

!BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'!
vertical

	self vResizing: #spaceFill.! !


!BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'!
defaultBorderWidth
"answer the default border width for the receiver"
	^ 0! !

!BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color black! !

!BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'!
initialize
	"initialize the state of the receiver"
	super initialize.
""
	self extent: 1 @ 1! !

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

BorderedSubpaneDividerMorph class
	instanceVariableNames: ''!

!BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'!
forBottomEdge
	^self new horizontal resizingEdge: #bottom! !

!BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'!
forTopEdge
	^self new horizontal resizingEdge: #top! !

!BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'!
horizontal
	^self new horizontal! !

!BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'!
vertical
	^self new vertical! !
CornerGripMorph subclass: #BottomLeftGripMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!BottomLeftGripMorph commentStamp: 'jmv 1/29/2006 17:17' prior: 0!
I am the handle in the left bottom of windows used for resizing them.!


!BottomLeftGripMorph methodsFor: 'target resize' stamp: 'jmv 1/29/2006 18:06'!
apply: delta 
	| oldBounds |
	oldBounds := target bounds.
	target
		bounds: (oldBounds origin + (delta x @ 0) corner: oldBounds corner + (0 @ delta y))! !


!BottomLeftGripMorph methodsFor: 'drawing' stamp: 'jmv 2/19/2006 14:23'!
drawOn: aCanvas

	| dotBounds alphaCanvas windowBorderWidth dotBounds2 |

	windowBorderWidth _ SystemWindow borderWidth.
	bounds _ self bounds.
	alphaCanvas _ aCanvas asAlphaBlendingCanvas: 0.7.	
	"alphaCanvas
		frameRectangle: bounds color: Color blue."

	dotBounds _ (bounds insetBy: 1).
	dotBounds2 _ dotBounds right: (dotBounds left + windowBorderWidth).
	dotBounds2 _ dotBounds2 top: (dotBounds2 bottom - windowBorderWidth).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self handleColor.
	
	dotBounds2 _ dotBounds left: (dotBounds left + windowBorderWidth).
	dotBounds2 _ dotBounds2 top: (dotBounds2 bottom - windowBorderWidth).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self handleColor.

	dotBounds2 _ dotBounds2 left: (dotBounds2 left + 7).
	dotBounds2 _ dotBounds2 right: (dotBounds2 right - 7).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self dotColor.

	dotBounds2 _ dotBounds right: (dotBounds left + windowBorderWidth).
	dotBounds2 _ dotBounds2 bottom: (dotBounds2 bottom - windowBorderWidth).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self handleColor.

	dotBounds2 _ dotBounds2 top: (dotBounds2 top + 7).
	dotBounds2 _ dotBounds2 bottom: (dotBounds2 bottom - 7).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self dotColor! !


!BottomLeftGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:26'!
gripLayoutFrame
	^ LayoutFrame
		fractions: (0 @ 1 corner: 0 @ 1)
		offsets: (0 @ (0 - self defaultHeight) corner: self defaultWidth @ 0)! !

!BottomLeftGripMorph methodsFor: 'accessing' stamp: 'md 2/24/2006 22:43'!
ptName
	^#bottomLeft! !

!BottomLeftGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:52'!
resizeCursor

	^ Cursor resizeForEdge: #bottomLeft! !
CornerGripMorph subclass: #BottomRightGripMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!BottomRightGripMorph commentStamp: 'jmv 1/29/2006 17:18' prior: 0!
I am the handle in the right bottom of windows used for resizing them.!


!BottomRightGripMorph methodsFor: 'target resize' stamp: 'jmv 1/29/2006 17:59'!
apply: delta 
	| oldBounds |
	oldBounds := target bounds.
	target
		bounds: (oldBounds origin corner: oldBounds corner + delta)! !


!BottomRightGripMorph methodsFor: 'drawing' stamp: 'jmv 2/19/2006 14:23'!
drawOn: aCanvas

	| dotBounds alphaCanvas windowBorderWidth dotBounds2 |

	windowBorderWidth _ SystemWindow borderWidth.
	bounds _ self bounds.
	alphaCanvas _ aCanvas asAlphaBlendingCanvas: 0.7.	
	"alphaCanvas
		frameRectangle: bounds color: Color blue."

	dotBounds _ (bounds insetBy: 1).
	dotBounds2 _ dotBounds left: (dotBounds right - windowBorderWidth).
	dotBounds2 _ dotBounds2 top: (dotBounds2 bottom - windowBorderWidth).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self handleColor.
	
	dotBounds2 _ dotBounds right: (dotBounds right - windowBorderWidth).
	dotBounds2 _ dotBounds2 top: (dotBounds2 bottom - windowBorderWidth).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self handleColor.

	dotBounds2 _ dotBounds2 left: (dotBounds2 left + 7).
	dotBounds2 _ dotBounds2 right: (dotBounds2 right - 7).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self dotColor.

	dotBounds2 _ dotBounds left: (dotBounds right - windowBorderWidth).
	dotBounds2 _ dotBounds2 bottom: (dotBounds2 bottom - windowBorderWidth).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self handleColor.

	dotBounds2 _ dotBounds2 top: (dotBounds2 top + 7).
	dotBounds2 _ dotBounds2 bottom: (dotBounds2 bottom - 7).
	alphaCanvas
		fillRectangle: dotBounds2
		color: self dotColor! !


!BottomRightGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:27'!
gripLayoutFrame
	^ LayoutFrame
		fractions: (1 @ 1 corner: 1 @ 1)
		offsets: (0 - self defaultWidth @ (0 - self defaultHeight) corner: 0 @ 0)! !

!BottomRightGripMorph methodsFor: 'accessing' stamp: 'md 2/24/2006 22:43'!
ptName
	^#bottomRight! !

!BottomRightGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:51'!
resizeCursor

	^ Cursor resizeForEdge: #bottomRight! !
Morph subclass: #BouncingAtomsMorph
	instanceVariableNames: 'damageReported infectionHistory transmitInfection recentTemperatures temperature'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MorphicExtras-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: 'change reporting' 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: 'drawing' stamp: 'di 1/4/1999 20:22'!
areasRemainingToFill: aRectangle
	color isTranslucent
		ifTrue: [^ Array with: aRectangle]
		ifFalse: [^ aRectangle areasOutside: self bounds]! !

!BouncingAtomsMorph methodsFor: 'drawing'!
drawOn: aCanvas
	"Clear the damageReported flag when redrawn."

	super drawOn: aCanvas.
	damageReported _ false.! !


!BouncingAtomsMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:14'!
defaultColor
"answer the default color/fill style for the receiver"
	^ Color
		r: 0.8
		g: 1.0
		b: 0.8! !

!BouncingAtomsMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:14'!
initialize
	"initialize the state of the receiver"
	super initialize.
	""
	damageReported _ false.
	self extent: 400 @ 250.

	infectionHistory _ OrderedCollection new.
	transmitInfection _ false.
	self addAtoms: 30! !

!BouncingAtomsMorph methodsFor: 'initialization' stamp: 'ar 8/13/2003 11:41'!
intoWorld: aWorld
	"Make sure report damage at least once"
	damageReported _ false.
	super intoWorld: aWorld.! !


!BouncingAtomsMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:15'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'startInfection' translated action: #startInfection.
	aCustomMenu add: 'set atom count' translated action: #setAtomCount.
	aCustomMenu add: 'show infection history' translated 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: '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' stamp: 'aoy 2/15/2003 21:38'!
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.
					continue := 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)].
									(j := j + 1) <= count]
								ifFalse: [false]]].
	^collisions! !

!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: 'dgd 2/22/2003 13:36'!
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 isNil 
		ifTrue: 
			[recentTemperatures := OrderedCollection new.
			20 timesRepeat: [recentTemperatures add: 0]].
	recentTemperatures removeLast.
	recentTemperatures addFirst: currentTemperature.
	temperature := recentTemperatures sum asFloat / recentTemperatures size! !


!BouncingAtomsMorph methodsFor: 'stepping and presenter' 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: 'submorphs-add/remove'!
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: 'testing' stamp: 'jm 6/28/1998 18:10'!
stepTime
	"As fast as possible."

	^ 0
! !

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

BouncingAtomsMorph class
	instanceVariableNames: ''!

!BouncingAtomsMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:57'!
initialize

	self registerInFlapsRegistry.	! !

!BouncingAtomsMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:58'!
registerInFlapsRegistry
	"Register the receiver in the system's flaps registry"
	self environment
		at: #Flaps
		ifPresent: [:cl | cl registerQuad: #(BouncingAtomsMorph	new	'Bouncing Atoms'	'Atoms, mate')
						forFlapNamed: 'Widgets']! !

!BouncingAtomsMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:32'!
unload
	"Unload the receiver from global registries"

	self environment at: #Flaps ifPresent: [:cl |
	cl unregisterQuadsWithReceiver: self] ! !


!BouncingAtomsMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:21'!
descriptionForPartsBin
	^ self partName:	'BouncingAtoms'
		categories:		#('Demo')
		documentation:	'The original, intensively-optimized bouncing-atoms simulation by John Maloney'! !
ParseNode subclass: #BraceNode
	instanceVariableNames: 'elements sourceLocations emitNode'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Compiler-ParseNodes'!
!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: '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: '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: '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: '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: '*eToys-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 )"
! !
Halt subclass: #BreakPoint
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Tools'!
!BreakPoint commentStamp: 'md 11/18/2003 09:32' prior: 0!
This exception is raised on executing a breakpoint.

"BreakPoint signal" is called from "Object>>break".!

Object subclass: #BreakpointManager
	instanceVariableNames: ''
	classVariableNames: 'Installed'
	poolDictionaries: ''
	category: 'System-Tools'!
!BreakpointManager commentStamp: 'emm 5/30/2002 14:20' prior: 0!
This class manages methods that include breakpoints.
It has several class methods to install and uninstall breakpoints.

Evaluating "BreakpointManager clear" will remove all installed breakpoints in the system.

Known issues:
- currently, only break-on-entry type of breakpoints are supported
- emphasis change not implemented for MVC browsers
- uninstalling the breakpoint doesn't auto-update other browsers
- uninstalling a breakpoint while debugging should restart-simulate the current method

Ernest Micklei, 2002

Send comments to emicklei@philemonworks.com!


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

BreakpointManager class
	instanceVariableNames: ''!

!BreakpointManager class methodsFor: 'examples' stamp: 'emm 5/30/2002 14:12'!
testBreakpoint
	"In the menu of the methodList, click on -toggle break on entry-
	and evaluate the following:"

	"BreakpointManager testBreakpoint"

	Transcript cr; show: 'Breakpoint test'! !


!BreakpointManager class methodsFor: 'install-uninstall' stamp: 'emm 5/30/2002 09:37'!
installInClass: aClass selector: aSymbol 
	"Install a new method containing a breakpoint.
	The receiver will remember this for unstalling it later"

	| breakMethod |
	breakMethod _ self compilePrototype: aSymbol in: aClass.
	breakMethod isNil
		ifTrue: [^ nil].
	self installed at: breakMethod put: aClass >> aSymbol. "old method"
	aClass methodDictionary at: aSymbol put: breakMethod.! !

!BreakpointManager class methodsFor: 'install-uninstall' stamp: 'md 2/15/2006 21:25'!
unInstall: breakMethod 

	| class selector oldMethod |
	oldMethod := self installed at: breakMethod ifAbsent:[^self].
	class := breakMethod methodClass.
	selector := breakMethod selector.
	
	(class>>selector) == breakMethod ifTrue:[	
			class methodDictionary at: selector put: oldMethod].
	self installed removeKey: breakMethod! !


!BreakpointManager class methodsFor: 'intialization-release' stamp: 'emm 5/30/2002 09:08'!
clear
	"BreakpointManager clear"

	self installed copy keysDo:[ :breakMethod |
		self unInstall: breakMethod].
		
		! !


!BreakpointManager class methodsFor: 'testing' stamp: 'emm 5/30/2002 09:22'!
methodHasBreakpoint: aMethod
	^self installed includesKey: aMethod! !


!BreakpointManager class methodsFor: 'private' stamp: 'emm 5/30/2002 09:36'!
breakpointMethodSourceFor: aSymbol in: aClass 
	"Compose new source containing a break statement (currently it will be the first,
	later we want to insert it in any place)"

	| oldSource methodNode breakOnlyMethodNode sendBreakMessageNode |
	oldSource := aClass sourceCodeAt: aSymbol.
	methodNode := aClass compilerClass new
		compile: oldSource
		in: aClass 
		notifying: nil 
		ifFail: [self error: '[breakpoint] unable to install breakpoint'].
	breakOnlyMethodNode := aClass compilerClass new
		compile: 'temporaryMethodSelectorForBreakpoint
self break.
^self'
		in: aClass 
		notifying: nil 
		ifFail: [self error: '[breakpoint] unable to install breakpoint'].
	sendBreakMessageNode := breakOnlyMethodNode block statements first.
	methodNode block statements addFirst: sendBreakMessageNode.
	^methodNode printString
	! !

!BreakpointManager class methodsFor: 'private' stamp: 'md 2/13/2006 14:35'!
compilePrototype: aSymbol in: aClass 
	"Compile and return a new method containing a break statement"

	| source node method |
	source := self breakpointMethodSourceFor: aSymbol in: aClass.
	node := aClass compilerClass new
		compile: source
		in: aClass 
		notifying: nil 
		ifFail: [self error: '[breakpoint] unable to install breakpoint'].
	node isNil ifTrue: [^nil].
	"dunno what the arguments mean..."
	method := node generate.
	^method! !

!BreakpointManager class methodsFor: 'private' stamp: 'emm 4/24/2002 23:24'!
installed
	Installed isNil ifTrue:[Installed := IdentityDictionary new].
	^Installed! !
TestCase subclass: #BrowseTest
	instanceVariableNames: 'originalBrowserClass originalHierarchyBrowserClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser-Tests'!

!BrowseTest methodsFor: 'running' stamp: 'mu 3/11/2004 15:57'!
setUp
	| systemNavigation |
	systemNavigation := SystemNavigation default.
	originalBrowserClass := systemNavigation browserClass.
	originalHierarchyBrowserClass := systemNavigation hierarchyBrowserClass.
	
	 systemNavigation browserClass: nil.
	 systemNavigation hierarchyBrowserClass: nil.
	
	! !

!BrowseTest methodsFor: 'running' stamp: 'mu 3/11/2004 15:57'!
tearDown
	| systemNavigation |
	systemNavigation := SystemNavigation default.
	 systemNavigation browserClass: originalBrowserClass.
	 systemNavigation hierarchyBrowserClass: originalHierarchyBrowserClass.! !


!BrowseTest methodsFor: 'testing' stamp: 'mu 3/6/2004 15:43'!
testBrowseClass
	"self debug: #testBrowseClass"
	| browsersBefore browsersAfter opened |
	self ensureMorphic.
	
	browsersBefore := self currentBrowsers.
	1 class browse.
	browsersAfter := self currentBrowsers.
	
	self assert:  (browsersAfter size  = (browsersBefore size + 1)).
	opened := browsersAfter removeAll: browsersBefore; yourself.
	self assert:  (opened size = 1).
	opened := opened asArray first.
	self assert: (opened model selectedClass == SmallInteger).
	
	opened delete
	
	
	! !

!BrowseTest methodsFor: 'testing' stamp: 'mu 3/11/2004 15:56'!
testBrowseHierarchyClass
	"self debug: #testBrowseHierarchyClass"
	| browsersBefore browsersAfter opened |
	self ensureMorphic.
	
	browsersBefore := self currentHierarchyBrowsers.
	1 class browseHierarchy.
	browsersAfter := self currentHierarchyBrowsers.
	
	self assert:  (browsersAfter size  = (browsersBefore size + 1)).
	opened := browsersAfter removeAll: browsersBefore; yourself.
	self assert:  (opened size = 1).
	opened := opened asArray first.
	self assert: (opened model selectedClass == SmallInteger).
	
	opened delete
	
	
	! !

!BrowseTest methodsFor: 'testing' stamp: 'mu 3/11/2004 15:52'!
testBrowseHierarchyInstance
	"self debug: #testBrowseHierarchyInstance"
	| browsersBefore browsersAfter opened |
	self ensureMorphic.
	
	browsersBefore := self currentHierarchyBrowsers.
	1 browseHierarchy.
	browsersAfter := self currentHierarchyBrowsers.
	
	self assert:  (browsersAfter size  = (browsersBefore size + 1)).
	opened := browsersAfter removeAll: browsersBefore; yourself.
	self assert:  (opened size = 1).
	opened := opened asArray first.
	self assert: (opened model selectedClass == SmallInteger).
	
	opened delete
	
	
	! !

!BrowseTest methodsFor: 'testing' stamp: 'mu 3/11/2004 16:00'!
testBrowseHierarchyMataclass
	"self debug: #testBrowseHierarchyMataclass"
	| browsersBefore browsersAfter opened |
	self ensureMorphic.
	
	browsersBefore := self currentHierarchyBrowsers.
	1 class class browseHierarchy.
	browsersAfter := self currentHierarchyBrowsers.
	
	self assert:  (browsersAfter size  = (browsersBefore size + 1)).
	opened := browsersAfter removeAll: browsersBefore; yourself.
	self assert:  (opened size = 1).
	opened := opened asArray first.
	self assert: (opened model selectedClass == Metaclass).
	
	opened delete
	
	
	! !

!BrowseTest methodsFor: 'testing' stamp: 'mu 3/6/2004 15:43'!
testBrowseInstance
	"self debug: #testBrowseInstance"
	| browsersBefore browsersAfter opened |
	self ensureMorphic.
	
	browsersBefore := self currentBrowsers.
	1 browse.
	browsersAfter := self currentBrowsers.
	
	self assert:  (browsersAfter size  = (browsersBefore size + 1)).
	opened := browsersAfter removeAll: browsersBefore; yourself.
	self assert:  (opened size = 1).
	opened := opened asArray first.
	self assert: (opened model selectedClass == SmallInteger).
	
	opened delete
	
	
	! !

!BrowseTest methodsFor: 'testing' stamp: 'mu 3/6/2004 15:44'!
testBrowseMetaclass
	"self debug: #testBrowseMetaclass"
	| browsersBefore browsersAfter opened |
	self ensureMorphic.
	
	browsersBefore := self currentBrowsers.
	1 class class browse.
	browsersAfter := self currentBrowsers.
	
	self assert:  (browsersAfter size  = (browsersBefore size + 1)).
	opened := browsersAfter removeAll: browsersBefore; yourself.
	self assert:  (opened size = 1).
	opened := opened asArray first.
	self assert: (opened model selectedClass == Metaclass).
	
	opened delete
	
	
	! !


!BrowseTest methodsFor: 'private' stamp: 'mu 3/6/2004 15:41'!
currentBrowsers
	^ (ActiveWorld submorphs
		select: [:each | (each isKindOf: SystemWindow)
				and: [each model isKindOf: Browser]]) asSet! !

!BrowseTest methodsFor: 'private' stamp: 'mu 3/11/2004 15:52'!
currentHierarchyBrowsers
	^ (ActiveWorld submorphs
		select: [:each | (each isKindOf: SystemWindow)
				and: [each model isKindOf: HierarchyBrowser]]) asSet! !

!BrowseTest methodsFor: 'private' stamp: 'mu 3/6/2004 15:27'!
ensureMorphic
	self isMorphic ifFalse: [self error: 'This test should be run in Morphic'].! !

!BrowseTest methodsFor: 'private' stamp: 'mu 3/6/2004 15:26'!
isMorphic
	^Smalltalk isMorphic! !
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: 'al 12/6/2005 22:36'!
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 == #newTrait
		ifTrue: [^Trait newTemplateIn: self selectedSystemCategoryName].
	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 classDefinitionText].
	editSelection == #editComment 
		ifTrue:
			[(theClass _ self selectedClass) ifNil: [^ ''].
			comment _ theClass comment.
			currentCompiledMethod _ theClass organization commentRemoteStr.
			^ comment size = 0
				ifTrue: ['This class has not yet been commented.']
				ifFalse: [comment]].
	editSelection == #hierarchy 
		ifTrue: [
			self selectedClassOrMetaClass isTrait
				ifTrue: [^'']
				ifFalse: [^self selectedClassOrMetaClass printHierarchy]].
	editSelection == #editMessageCategories 
		ifTrue: [^ self classOrMetaClassOrganizer printString].
	editSelection == #newMessage
		ifTrue:
			[^ (theClass _ self selectedClassOrMetaClass) 
				ifNil: ['']
				ifNotNil: [theClass sourceCodeTemplate]].
	editSelection == #editMessage
		ifTrue:
			[self showingByteCodes ifTrue: [^ self selectedBytecodes].
			currentCompiledMethod _ latestCompiledMethod.
			^ self selectedMessage].

	self error: 'Browser internal error: unknown edit selection.'! !

!Browser methodsFor: 'accessing' stamp: 'drs 1/6/2003 16:11'!
contentsSelection
	"Return the interval of text in the code pane to select when I set the pane's contents"

	messageCategoryListIndex > 0 & (messageListIndex = 0)
		ifTrue: [^ 1 to: 500]	"entire empty method template"
		ifFalse: [^ 1 to: 0]  "null selection"! !

!Browser methodsFor: 'accessing' stamp: 'al 4/24/2004 12:01'!
contents: input notifying: aController 
	"The retrieved information has changed and its source must now be
	 updated. The information can be a variety of things, depending on
	 the list selections (such as templates for class or message definition,
	 methods) or the user menu commands (such as definition, comment,
	 hierarchy).  Answer the result of updating the source."

	| aString aText theClass |
	self changed: #annotation.
	aString _ input asString.
	aText _ input asText.
	editSelection == #newTrait ifTrue: [^self defineTrait: input asString notifying: aController].
	editSelection == #editSystemCategories ifTrue: [^ self changeSystemCategories: aString].
	editSelection == #editClass | (editSelection == #newClass) ifTrue: [^ self defineClass: aString notifying: aController].
	editSelection == #editComment
		ifTrue: 
			[theClass _ self selectedClass.
			theClass
				ifNil: 
					[self inform: 'You must select a class
before giving it a comment.'.
					^ false].
			theClass comment: aText stamp: Utilities changeStamp.
			self changed: #classCommentText.
			^ 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: 
			[self inform: 'This text cannot be accepted
in this part of the browser.'.
			^ false].
	self error: 'unacceptable accept'! !

!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: 'sd 11/20/2005 21:26'!
editSelection: aSelection
	"Set the editSelection as requested."

	editSelection := aSelection.
	self changed: #editSelection.! !

!Browser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'!
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: 'rbb 3/1/2005 10:26'!
request: prompt initialAnswer: initialAnswer

	^ UIManager default
		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: 'accessing' stamp: 'sw 9/26/2002 17:56'!
suggestCategoryToSpawnedBrowser: aBrowser
	"aBrowser is a message-category browser being spawned from the receiver.  Tell it what it needs to know to get its category info properly set up."

	(self isMemberOf: Browser) "yecch, but I didn't invent the browser hierarchy"
		ifTrue:
			[aBrowser messageCategoryListIndex: (self messageCategoryList indexOf: self categoryOfCurrentMethod ifAbsent: [2])]
		ifFalse:
			[aBrowser setOriginalCategoryIndexForCurrentMethod]! !


!Browser methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:26'!
annotation
	"Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver."

	|  aSelector aClass |
	(aClass := self selectedClassOrMetaClass) == nil ifTrue: [^ '------'].
	self editSelection == #editComment ifTrue:
		[^ self annotationForSelector: #Comment ofClass: aClass].

	self editSelection == #editClass ifTrue:
		[^ self annotationForSelector: #Definition ofClass: aClass].
	(aSelector := self selectedMessageName) ifNil: [^ '------'].
	^ self annotationForSelector: aSelector ofClass: aClass! !


!Browser methodsFor: 'breakpoints' stamp: 'emm 5/30/2002 09:23'!
toggleBreakOnEntry
	"Install or uninstall a halt-on-entry breakpoint"

	| selectedMethod |
	self selectedClassOrMetaClass isNil ifTrue:[^self].
	selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName.
	selectedMethod hasBreakpoint
		ifTrue:
			[BreakpointManager unInstall: selectedMethod]
		ifFalse:
			[BreakpointManager 
				installInClass: self selectedClassOrMetaClass
				selector: self selectedMessageName].
	self changed: #messageList
		! !


!Browser methodsFor: 'class comment pane' stamp: 'nk 2/15/2004 13:20'!
buildMorphicCommentPane
	"Construct the pane that shows the class comment.
	Respect the Preference for standardCodeFont."

	| commentPane |
	commentPane := BrowserCommentTextMorph
				on: self
				text: #classCommentText
				accept: #classComment:notifying:
				readSelection: nil
				menu: #codePaneMenu:shifted:.
	commentPane font: Preferences standardCodeFont.
	^ commentPane! !

!Browser methodsFor: 'class comment pane' stamp: 'dew 3/5/2005 23:10'!
classComment: aText notifying: aPluggableTextMorph 
	"The user has just entered aText.
	It may be all red (a side-effect of replacing the default comment), so remove the color if it is."

	| theClass cleanedText redRange |
	theClass := self selectedClassOrMetaClass.
	theClass
		ifNotNil: [cleanedText := aText asText.
			redRange := cleanedText rangeOf: TextColor red startingAt: 1.
			redRange size = cleanedText size
				ifTrue: [cleanedText
						removeAttribute: TextColor red
						from: 1
						to: redRange last ].
			theClass comment: aText stamp: Utilities changeStamp].
	self changed: #classCommentText.
	^ true! !

!Browser methodsFor: 'class comment pane' stamp: 'md 2/24/2006 15:23'!
noCommentNagString

	^ Text string: 'THIS CLASS HAS NO COMMENT!!' translated attribute: TextColor red.
		! !


!Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:26'!
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 |
				ChangeSet current 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: 'sd 11/20/2005 21:26'!
classCommentText
	"return the text to display for the comment of the currently selected class"
	| theClass |
	theClass := self selectedClassOrMetaClass.
	theClass ifNil: [ ^''].

	^ theClass hasComment
		ifTrue: [  theClass comment  ]
		ifFalse: [ self noCommentNagString ]! !

!Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:26'!
classDefinitionText
	"return the text to display for the definition of the currently selected class"
	| theClass |
	theClass := self selectedClassOrMetaClass.
	theClass ifNil: [ ^''].

	^theClass definitionST80.! !

!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: 'rr 7/10/2006 11:47'!
classListMenu: aMenu shifted: shifted
	"Set up the menu to apply to the receiver's class list, honoring the #shifted boolean"

	ServiceGui browser: self classMenu: aMenu.
	ServiceGui onlyServices  ifTrue: [^aMenu].
	shifted
		ifTrue:
			[^ self shiftedClassListMenu: aMenu].
	aMenu addList: #(
		-
		('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)
		('find method wildcard...'	findMethodWithWildcard)
		-
		('more...'					offerShiftedClassListMenu)).
	^ aMenu
! !

!Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:26'!
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: 'sd 11/20/2005 21:30'!
createInstVarAccessors
	"Create getters and setters for all inst vars defined at the level of the current class selection, except do NOT clobber or override any selectors already understood by the instances of the selected class"

	| aClass newMessage setter |
	(aClass := self selectedClassOrMetaClass) ifNotNil:
		[aClass instVarNames do: 
			[:aName |
				(aClass canUnderstand: aName asSymbol)
					ifFalse:
						[newMessage := aName, '
	"Answer the value of ', aName, '"

	^ ', aName.
						aClass compile: newMessage classified: 'accessing' notifying: nil].
				(aClass canUnderstand: (setter := aName, ':') asSymbol)
					ifFalse:
						[newMessage := setter, ' anObject
	"Set the value of ', aName, '"

	', aName, ' := anObject'.
						aClass compile: newMessage classified: 'accessing' notifying: nil]]]! !

!Browser methodsFor: 'class functions' stamp: 'md 3/3/2006 11:02'!
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.
	
	((defTokens first = 'Trait' and: [defTokens second = 'named:'])
		or: [defTokens second = 'classTrait'])
		ifTrue: [^self defineTrait: defString notifying: aController].
		
	keywdIx _ defTokens findFirst: [:x | x beginsWith: 'category'].
	envt _ Smalltalk.
	keywdIx _ defTokens findFirst: [:x | '*subclass*' match: x].
	newClassName _ (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
	((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName])
		and: [envt includesKey: 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: #systemCategoryList.
				self changed: #classList.
				self clearUserEditFlag.
				self setClass: class selector: nil.
				"self clearUserEditFlag; editClass."
				^ true]
		ifFalse: [^ false]! !

!Browser methodsFor: 'class functions' stamp: 'nk 2/15/2004 13:23'!
editClass
	"Retrieve the description of the class definition."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	self editSelection: #editClass.
	self changed: #contents.
	self changed: #classCommentText.
! !

!Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:26'!
editComment
	"Retrieve the description of the class comment."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	metaClassIndicated := false.
	self editSelection: #editComment.
	self changed: #classSelectionChanged.
	self changed: #messageCategoryList.
	self changed: #messageList.
	self decorateButtons.
	self contentsChanged
! !

!Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:26'!
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 := self systemNavigation allClassesImplementing: whole.
			classes := 'these classes ' , classes printString.
			^reply , '  It is defined in ' , classes , '."
Smalltalk browseAllImplementorsOf: #' , whole].

	editSelection == #hierarchy
		ifTrue: 
			["Instance variables in subclasses"
			classes := self selectedClassOrMetaClass allSubclasses.
			classes := classes detect: [:each | (each instVarNames
						detect: [:name | name = string] ifNone: []) ~~ nil]
					ifNone: [^nil].
			classes := classes printString.
			^'"is an instance variable in class ' , classes , '."
' , classes , ' browseAllAccessesTo: ''' , string , '''.'].
	editSelection == #editSystemCategories ifTrue: [^nil].
	editSelection == #editMessageCategories ifTrue: [^nil].
	^nil! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'!
fileOutClass
	"Print a description of the selected class onto a file whose name is the 
	category name followed by .st."

Cursor write showWhile:
		[classListIndex ~= 0 ifTrue: [self selectedClass fileOut]]! !

!Browser methodsFor: 'class functions' stamp: 'rbb 3/1/2005 10:25'!
findMethod
	"Pop up a list of the current class's methods, and select the one chosen by the user"

	| aClass selectors reply cat messageCatIndex messageIndex |
	self classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	aClass := self selectedClassOrMetaClass.
	selectors := aClass selectors asSortedArray.
	selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.'. ^ self].
	reply := (SelectionMenu
		labelList: (Array with: 'Enter Wildcard'), selectors
		lines: #(1)
		selections: (Array with: 'EnterWildcard'), selectors) startUp.
	reply == nil ifTrue: [^ self].
	reply = 'EnterWildcard'
		ifTrue: [
			reply := UIManager default request: 'Enter partial method name:'.
			(reply isNil or: [reply isEmpty])
				ifTrue: [^self].
			(reply includes: $*)
				ifFalse: [reply := '*', reply, '*'].
			selectors := selectors select: [:each | reply match: each].
			selectors isEmpty ifTrue: [self inform: aClass name, ' has no matching methods.'. ^ self].
			reply := selectors size = 1
				ifTrue: [selectors first]
				ifFalse: [
					(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: 'rbb 3/1/2005 10:26'!
findMethodWithWildcard
	"Pop up a list of the current class's methods, and select the one chosen by the user"

	| aClass selectors reply cat messageCatIndex messageIndex |
	self classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	aClass := self selectedClassOrMetaClass.
	selectors := aClass selectors asSortedArray.
	selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.'. ^ self].

	reply := UIManager default request: 'Enter partial method name:'.
	(reply isNil or: [reply isEmpty])
		ifTrue: [^self].
	(reply includes: $*)
		ifFalse: [reply := '*', reply, '*'].
	selectors := selectors select: [:each | reply match: each].
	selectors isEmpty ifTrue: [self inform: aClass name, ' has no matching methods.'. ^ self].
	reply := selectors size = 1
		ifTrue: [selectors first]
		ifFalse: [
			(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: 'nk 2/14/2004 15:09'!
hierarchy
	"Display the inheritance hierarchy of the receiver's selected class."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	self editSelection: #hierarchy.
	self changed: #editComment.
	self contentsChanged.
	^ self! !

!Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:07'!
makeNewSubclass

	self selectedClassOrMetaClass ifNil: [^ self].
	self okToChange ifFalse: [^ self].
	self editSelection: #newClass.
	self contentsChanged! !

!Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:09'!
plusButtonHit
	"Cycle among definition, comment, and hierachy"

	editSelection == #editComment
		ifTrue: [self hierarchy. ^ self].
	editSelection == #hierarchy
		ifTrue: [self editSelection: #editClass.
			classListIndex = 0 ifTrue: [^ self].
			self okToChange ifFalse: [^ self].
			self changed: #editComment.
			self contentsChanged.
			^ self].
	self editComment! !

!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: 'sw 3/5/2001 18:04'!
removeClass
	"If the user confirms the wish to delete the class, do so"

	super removeClass ifTrue:
		[self classListIndex: 0]! !

!Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:26'!
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 := self systemNavigation
				allCallsOn: (Smalltalk associationAt: newName).
	obs isEmpty
		ifFalse: [self systemNavigation
				browseMessageList: obs
				name: 'Obsolete References to ' , oldName
				autoSelect: oldName]! !

!Browser methodsFor: 'class functions' stamp: 'md 7/29/2005 15:59'!
shiftedClassListMenu: aMenu
	"Set up the menu to apply to the receiver's class list when the shift key is down"

	^ aMenu addList: #(
			-
			('unsent methods'			browseUnusedMethods	'browse all methods defined by this class that have no senders')
			('unreferenced inst vars'	showUnreferencedInstVars	'show a list of all instance variables that are not referenced in methods')
			('unreferenced class vars'	showUnreferencedClassVars	'show a list of all class variables that are not referenced in methods')
			('subclass template'			makeNewSubclass		'put a template into the code pane for defining of a subclass of this class')
			-
			('sample instance'			makeSampleInstance		'give me a sample instance of this class, if possible')
			('inspect instances'			inspectInstances			'open an inspector on all the extant instances of this class')
			('inspect subinstances'		inspectSubInstances		'open an inspector on all the extant instances of this class and of all of its subclasses')
			-
			('add all meths to current chgs'		addAllMethodsToCurrentChangeSet
																'place all the methods defined by this class into the current change set')
			('create inst var accessors'	createInstVarAccessors	'compile instance-variable access methods for any instance variables that do not yet have them')
			-
			('more...'					offerUnshiftedClassListMenu	'return to the standard class-list menu'))! !


!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: 'sd 11/20/2005 21:26'!
classListIndex: anInteger 
	"Set anInteger to be the index of the current class selection."

	| className |

	classListIndex := anInteger.
	self setClassOrganizer.
	messageCategoryListIndex := 0.
	messageListIndex := 0.
	self classCommentIndicated
		ifTrue: []
		ifFalse: [self 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: #classCommentText.
	self changed: #classListIndex.	"update my selection"
	self changed: #messageCategoryList.
	self changed: #messageList.
	self changed: #relabel.
	self contentsChanged! !

!Browser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'!
classListSingleton

	| name |
	name := self selectedClassName.
	^ name ifNil: [Array new]
		ifNotNil: [Array with: name]! !

!Browser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'!
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: [^ Beeper 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: 'sd 11/20/2005 21:26'!
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: 'sd 11/20/2005 21:26'!
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: 'rr 7/10/2006 11:48'!
codePaneMenu: aMenu shifted: shifted 
	ServiceGui browser: self codePaneMenu: aMenu.
	ServiceGui onlyServices ifTrue: [^ aMenu].
	super codePaneMenu: aMenu shifted: shifted.
	^ aMenu! !

!Browser methodsFor: 'code pane' stamp: 'sd 11/20/2005 21:26'!
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 ifNil:
			[ self selectOriginalCategoryForCurrentMethod 	
										ifFalse:["Select the '--all--' category"
											self messageCategoryListIndex: 1]]. 


	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: 'sw 5/18/2001 20:55'!
showBytecodes
	"Show or hide the bytecodes of the selected method -- an older protocol now mostly not relevant."

	self toggleShowingByteCodes! !


!Browser methodsFor: 'construction' stamp: 'sd 11/20/2005 21:26'!
addLowerPanesTo: window at: nominalFractions with: editString
	| commentPane |
	super addLowerPanesTo: window at: nominalFractions with: editString.
	commentPane := self buildMorphicCommentPane.
	window addMorph: commentPane fullFrame: (LayoutFrame fractions: (0@0.75 corner: 1@1)).
	self changed: #editSelection.! !


!Browser methodsFor: 'copying' stamp: 'sd 11/20/2005 21:26'!
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: 'nk 6/12/2004 17:43'!
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: [ | srcClass srcSelector srcCategory |
			srcClass := transferMorph passenger key.
			srcSelector := transferMorph passenger value.
			srcCategory := srcBrowser selectedMessageCategoryName.
			srcCategory
				ifNil: [srcCategory := srcClass organization categoryOfElement: srcSelector].
			success := self
						acceptMethod: srcSelector
						messageCategory: srcCategory
						class: srcClass
						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! !

!Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'!
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: 'al 4/24/2004 11:50'!
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 classSide]
						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: 'sd 11/20/2005 21:26'!
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: 'nk 4/22/2004 18:00'!
changeMessageCategoryForMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel insideClassOrMeta: classOrMeta internal: internal copySemantic: copyFlag 
	"Recategorize the method named by methodSel. 
	If the dstMessageCategorySel is the allCategory, then recategorize 
	it from its parents."
	| success messageCategorySel |
	copyFlag
		ifTrue: [^ false].
	"only move semantic"
	messageCategorySel := dstMessageCategorySel
				ifNil: [srcMessageCategorySel].
	(success := messageCategorySel notNil
					and: [messageCategorySel ~= srcMessageCategorySel])
		ifTrue: [success := messageCategorySel == ClassOrganizer allCategory
						ifTrue: [self recategorizeMethodSelector: methodSel]
						ifFalse: [(classOrMeta organization categories includes: messageCategorySel)
								and: [classOrMeta organization
										classify: methodSel
										under: messageCategorySel
										suppressIfDefault: false.
									true]]].
	success
		ifTrue: [self changed: #messageList.
			internal
				ifFalse: [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: 'sd 11/20/2005 21:26'!
dragPassengerFor: item inMorph: dragSource 
	| transferType smn |
	(dragSource isKindOf: PluggableListMorph)
		ifFalse: [^nil].
	transferType := self dragTransferTypeForMorph: dragSource.
	transferType == #classList
		ifTrue: [^self selectedClass].
	transferType == #messageList
		ifFalse: [ ^nil ].
	smn := self selectedMessageName ifNil: [ ^nil ].
	(MessageSet isPseudoSelector: smn) ifTrue: [ ^nil ].

	^ self selectedClassOrMetaClass -> smn.
! !

!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: 'ls 6/22/2001 23:21'!
dstCategoryDstListMorph: dstListMorph
	^(dstListMorph getListSelector == #systemCategoryList)
		ifTrue: [dstListMorph potentialDropItem ]
		ifFalse: [self selectedSystemCategoryName]! !

!Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'!
dstClassDstListMorph: dstListMorph
	| dropItem |
	^(dstListMorph getListSelector == #classList)
		ifTrue: [(dropItem := dstListMorph potentialDropItem) ifNotNil: [Smalltalk at: dropItem withBlanksCondensed asSymbol]]
		ifFalse: [dstListMorph model selectedClass]! !

!Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'!
dstMessageCategoryDstListMorph: dstListMorph
	| dropItem |
	^dstListMorph getListSelector == #messageCategoryList
		ifTrue: 
			[dropItem := dstListMorph potentialDropItem.
			dropItem ifNotNil: [dropItem asSymbol]]
		ifFalse: [self selectedMessageCategoryName ifNil: [ Categorizer default ]]! !

!Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'!
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' stamp: 'sd 11/20/2005 21:26'!
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: 'sd 11/20/2005 21:26'!
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: 'md 2/